From 2494407a750053daa61718fac371487d04818e57 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 17 Mar 1997 20:35:30 +0000
Subject: [PATCH] [project @ 1997-03-17 20:34:25 by simonpj] More small changes
towards 2.02
---
Makefile | 25 --
docs/Makefile | 2 +-
docs/installing.lit | 66 ++--
ghc/Makefile | 4 +-
ghc/compiler/Makefile | 3 +-
ghc/compiler/absCSyn/AbsCSyn.lhs | 2 +-
ghc/compiler/absCSyn/PprAbsC.lhs | 10 +-
ghc/compiler/basicTypes/Unique.lhs | 2 +
ghc/compiler/deSugar/DsMonad.lhs | 2 +-
ghc/compiler/prelude/PrelInfo.lhs | 4 +-
ghc/compiler/prelude/PrimOp.lhs | 83 +++--
ghc/compiler/reader/Lex.lhs | 2 +-
ghc/compiler/rename/RnIfaces.lhs | 64 ++--
ghc/compiler/rename/RnMonad.lhs | 1 -
ghc/compiler/specialise/Specialise.lhs | 416 ++++++++++---------------
ghc/compiler/typecheck/TcGenDeriv.lhs | 10 +-
ghc/compiler/utils/FastString.lhs | 8 +-
ghc/docs/Makefile | 2 +-
ghc/driver/ghc-asm.lprl | 96 +++---
ghc/includes/StgMacros.lh | 11 +-
ghc/lib/Makefile | 11 +-
ghc/lib/cbits/stgio.h | 4 +
ghc/lib/ghc/GHC.hi-boot | 1 +
ghc/lib/ghc/IOBase.lhs | 8 +
ghc/lib/ghc/IOHandle.lhs | 61 +++-
ghc/lib/glaExts/Foreign.lhs | 17 +-
ghc/lib/required/Directory.lhs | 170 ++++++++--
ghc/lib/required/IO.lhs | 46 ++-
ghc/lib/required/Time.lhs | 180 ++++++-----
ghc/mk/boilerplate.mk | 6 +-
ghc/mk/paths.mk | 8 +-
ghc/runtime/Makefile | 6 +-
ghc/runtime/prims/PrimMisc.lc | 2 +
mk/config.mk.in | 47 +--
mk/target.mk | 3 +-
35 files changed, 809 insertions(+), 574 deletions(-)
diff --git a/Makefile b/Makefile
index eca7ef40768f..204d5ecc8079 100644
--- a/Makefile
+++ b/Makefile
@@ -65,28 +65,3 @@ dist :: dist-pre
include $(TOP)/mk/target.mk
dist :: dist-post
-#
-# Automatically remake update configuration files
-# (from autoconf manual)
-#
-configure: configure.in
- autoconf
-#
-# autoheader might not change config.h.in, so touch a stamp file.
-#
-mk/config.h.in: mk/stamp-h.in
-mk/stamp-h.in: configure.in
- autoheader
- echo timestamp > mk/stamp-h.in
-
-mk/config.h: mk/stamp-h
-mk/stamp-h: mk/config.h.in config.status
- ./config.status
-
-config.status: configure
- ./config.status --recheck
-
-.PHONY: config
-
-config: config.status
- @:
diff --git a/docs/Makefile b/docs/Makefile
index 851469d476a3..b2164c464f2e 100644
--- a/docs/Makefile
+++ b/docs/Makefile
@@ -1,7 +1,7 @@
TOP = ..
include $(TOP)/mk/boilerplate.mk
-DOC_SRCS = installing.lit release.lit
+DOC_SRCS = installing.lit
SRC_TEXI2HTML_OPTS += -number -monolithic -invisible xbm
diff --git a/docs/installing.lit b/docs/installing.lit
index 81bdeee2f084..d2d9bb32fa83 100644
--- a/docs/installing.lit
+++ b/docs/installing.lit
@@ -784,6 +784,19 @@ and you're on the road again.
You need to be a bit careful, though, that any new files you create
(if you do any development work) are in the source tree, not a build tree!
+Remember, that the source files in the build tree are {\em symbolic
+links} to the files in the source tree. (The build tree soon
+accumulates lots of built files like @Foo.o@, as well.) You can {\em
+delete} a source file from the build tree without affecting the source
+tree (though it's an odd thing to do). On the other hand, if you {\em
+edit} a source file from the build tree, you'll edit the source-tree
+file directly. (You can set up Emacs so that if you edit a source
+file from the build tree, Emacs will silently create an edited copy of
+the source file in the build tree, leaving the source file unchanged;
+but the danger is that you think you've edited the source file whereas
+actually all you've done is edit the build-tree copy. More commonly
+you do want to edit the source file.)
+
Like the source tree, the top level of your build tree must (a linked copy of)
the root directory of the @fptools@ suite.
Inside Makefiles, the root of your build tree is called @$(FPTOOLS_TOP)@.
@@ -813,27 +826,32 @@ Or, you might want to compile it with debugging on (so that
extra consistency-checking code gets included) or off. And so on.
All of this stuff is called the {\em configuration} of your build.
-You set the configuration using an exciting two-step process.
+You set the configuration using an exciting three-step process.
\begin{description}
-\item[Step 1: system configuration.] This is easy, provided you
-have the programs mentioned in Section~\ref{sect_std-utils}. Just
-@cd@ to @$(FPTOOLS)@ and say @gmake configure@. This
-command does three things:
-\begin{itemize}
-\item
-It runs a GNU program called @autoconf@, which
+\item[Step 1: get ready for configuration.]
+Change directory to @$(FPTOOLS)@ and issue the following two commands (with no arguments):
+\begin{enumerate}
+\item @autoconf@. This GNU program
converts @$(FPTOOLS)/configure.in@ to a shell script
called @$(FPTOOLS)/configure@.
-This step is completely platform-independent; it just means
+\item @autoheader@. This second GNU program converts
+@$(FPTOOLS)/configure.in@ to @$(FPTOOLS)/mk/config.h.in@.
+\end{enumerate}
+Both these steps are completely platform-independent; they just mean
that the human-written file (@configure.in@) can be short, although
-the resulting shell script, @configure@ is long.
+the resulting shell script, @configure@, and @mk/config.h.in@, are long.
-\item It runs a second GNU program called @autoheader@, which converts
-@$(FPTOOLS)/configure.in@ to @$(FPTOOLS)/mk/config.h.in@.
-Again, this step is platform-independent.
+In case you don't have @autoconf@ and @autoheader@ we distribute
+the results, @configure@, and @mk/config.h.in@, with the source distribution.
+They aren't kept in the repository, though.
-\item It then runs the newly-created @configure@ script. @configure@'s mission
+\item[Step 2: system configuration.]
+Runs the newly-created @configure@ script, thus:
+\begin{verbatim}
+ ./configure
+\end{verbatim}
+@configure@'s mission
is to scurry round your computer working out what architecture it has,
what operating system, whether it has the @vfork@ system call,
where @yacc@ is kept, whether @gcc@ is available, where various
@@ -853,10 +871,9 @@ all Makefiles.
The latter is @#include@d by various C programs, which
can thereby make use of configuration information.
\end{itemize}
-\end{itemize}
-\item[Step 2: build configuration.] Next, you say how this build
+\item[Step 3: build configuration.] Next, you say how this build
of @fptools@ is to differ from the standard defaults by creating a new
file @mk/build.mk@
{\em in the build tree}. This file is the one and only
@@ -883,18 +900,18 @@ want to change. (The override occurs because the main boilerplate file,
For example, @config.mk.in@ contains the definition:
\begin{verbatim}
- SUBDIRS = glafp-utils literate ghc
+ ProjectsToBuild = glafp-utils literate ghc hslibs
\end{verbatim}
The accompanying comment explains that this is the list of enabled
projects; that is, if (after configuring) you type @gmake all@
in @FPTOOLS_TOP@ three specified projects will be made.
If you want to add @happy@, you can add this line to @build.mk@:
\begin{verbatim}
- SUBDIRS += happy
+ ProjectsToBuild += happy
\end{verbatim}
or, if you prefer,
\begin{verbatim}
- SUBDIRS = glafp-utils literate ghc happy
+ ProjectsToBuild = glafp-utils literate ghc hslibs happy
\end{verbatim}
(GNU @make@ allows existing definitions to have new text appended using
the ``@+=@'' operator, which is quite a convenient feature.)
@@ -941,10 +958,19 @@ to happen there now.
\begin{verbatim}
cd /scratch/joe-bloggs/myfptools-sun4
\end{verbatim}
+\item Prepare for system configuration:
+\begin{verbatim}
+ autoconf
+ autoheader
+\end{verbatim}
+(You can skip this step if you are starting from a source distribution,
+and you already have @configure@ and @mk/config.h.in@.)
+
\item Do system configuration:
\begin{verbatim}
- gmake configure
+ ./configure
\end{verbatim}
+
\item Create the file @mk/build.mk@,
adding definitions for your desired configuration options.
\begin{verbatim}
diff --git a/ghc/Makefile b/ghc/Makefile
index 3876e1b6708c..42b121c61694 100644
--- a/ghc/Makefile
+++ b/ghc/Makefile
@@ -1,5 +1,5 @@
#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.3 1997/03/14 07:53:55 simonpj Exp $
+# $Id: Makefile,v 1.4 1997/03/17 20:34:29 simonpj Exp $
#
TOP=.
@@ -49,7 +49,7 @@ boot ::
$(line)
@echo "Booting Prelude libraries"
$(line)
- @$(MAKE) -C compiler boot
+ @$(MAKE) -C lib boot
# "CONTRIB" is also a SUBDIR, but there is nothing to build there.
diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index b0b54d0a9bf2..972a8ca0acf6 100644
--- a/ghc/compiler/Makefile
+++ b/ghc/compiler/Makefile
@@ -1,5 +1,5 @@
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.8 1997/03/14 07:55:43 simonpj Exp $
+# $Id: Makefile,v 1.9 1997/03/17 20:34:30 simonpj Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
@@ -226,6 +226,7 @@ all :: hsp
hsp: parser/printtree.o parser/main.o libhsp.a
$(CC) -o $@ $(CC_OPTS) $^
+CLEAN_FILES += hsp
#-----------------------------------------------------------------------------
# Interface files
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index be099d0b1408..28cab7968751 100644
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -433,7 +433,7 @@ data MagicId
-- Argument and return registers
| VanillaReg -- pointers, unboxed ints and chars
- PrimRep -- PtrRep, IntRep, CharRep, StablePtrRep or ForeignObjRep
+ PrimRep -- PtrRep, IntRep, CharRep, StablePtrRep or ForeignObjRep
-- (in case we need to distinguish)
FAST_INT -- its number (1 .. mAX_Vanilla_REG)
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index b2e60c492a02..7fba22e30f3d 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -747,20 +747,22 @@ ppr_casm_results sty [r] liveness
(result_type, assign_result)
= case r_kind of
-{- @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
- Instead, external references have to be turned into ForeignObjs
+{-
+ @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 ->
(uppPStr SLIT("StgForeignObj"),
uppBesides [ uppPStr SLIT("constructForeignObj"),uppChar '(',
liveness, uppComma,
result_reg, uppComma,
local_var,
- pp_paren_semi ]) -}
+ pp_paren_semi ])
+-}
_ ->
(pprPrimKind sty r_kind,
uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 5f14e9fed877..3dbdbcd8873c 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -195,6 +195,7 @@ module Unique (
stateTyConKey,
synchVarPrimTyConKey,
thenMClassOpKey,
+ toEnumClassOpKey,
traceIdKey,
trueDataConKey,
unpackCString2IdKey,
@@ -680,4 +681,5 @@ mainPrimIoKey = mkPreludeMiscIdUnique 67
returnMClassOpKey = mkPreludeMiscIdUnique 68
-- Used for minusClassOp 69
otherwiseIdKey = mkPreludeMiscIdUnique 70
+toEnumClassOpKey = mkPreludeMiscIdUnique 71
\end{code}
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 38e567a7ea06..c2034d75e5cc 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -282,7 +282,7 @@ pprDsWarnings sty warns
= ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)]
pp_match CaseMatch pats
- = ppHang (ppPStr SLIT("in a group of case alternative beginning:"))
+ = ppHang (ppPStr SLIT("in a group of case alternatives beginning:"))
4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
pp_match PatBindMatch pats
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 98364f2573f2..426eb62e1bbb 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -15,7 +15,7 @@ module PrelInfo (
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,
+ enumFromThenTo_RDR, fromEnum_RDR, toEnum_RDR,
range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, readList_RDR,
showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR,
eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR,
@@ -299,6 +299,7 @@ knownKeyNames
, (enumFromTo_RDR, enumFromToClassOpKey)
, (enumFromThenTo_RDR, enumFromThenToClassOpKey)
, (fromEnum_RDR, fromEnumClassOpKey)
+ , (toEnum_RDR, toEnumClassOpKey)
, (eq_RDR, eqClassOpKey)
, (thenM_RDR, thenMClassOpKey)
, (returnM_RDR, returnMClassOpKey)
@@ -361,6 +362,7 @@ creturnableClass_RDR = tcQual (fOREIGN, SLIT("CReturnable"))
fromInt_RDR = varQual (pREL_BASE, SLIT("fromInt"))
fromInteger_RDR = varQual (pREL_BASE, SLIT("fromInteger"))
minus_RDR = varQual (pREL_BASE, SLIT("-"))
+toEnum_RDR = varQual (pREL_BASE, SLIT("toEnum"))
fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum"))
enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom"))
enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo"))
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index bd24ebe37d55..7ba7dd392b45 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -154,7 +154,8 @@ data PrimOp
| TakeMVarOp | PutMVarOp
| ReadIVarOp | WriteIVarOp
- | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL)
+ | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL)
+ | WriteForeignObjOp -- modifying foreign objects [obscuro factor: 200]
| MakeStablePtrOp | DeRefStablePtrOp
\end{code}
@@ -413,26 +414,27 @@ tagOf_PrimOp PutMVarOp = ILIT(152)
tagOf_PrimOp ReadIVarOp = ILIT(153)
tagOf_PrimOp WriteIVarOp = ILIT(154)
tagOf_PrimOp MakeForeignObjOp = ILIT(155)
-tagOf_PrimOp MakeStablePtrOp = ILIT(156)
-tagOf_PrimOp DeRefStablePtrOp = ILIT(157)
-tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(158)
-tagOf_PrimOp ErrorIOPrimOp = ILIT(159)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(160)
-tagOf_PrimOp SeqOp = ILIT(161)
-tagOf_PrimOp ParOp = ILIT(162)
-tagOf_PrimOp ForkOp = ILIT(163)
-tagOf_PrimOp DelayOp = ILIT(164)
-tagOf_PrimOp WaitReadOp = ILIT(165)
-tagOf_PrimOp WaitWriteOp = ILIT(166)
-
-tagOf_PrimOp ParGlobalOp = ILIT(167)
-tagOf_PrimOp ParLocalOp = ILIT(168)
-tagOf_PrimOp ParAtOp = ILIT(169)
-tagOf_PrimOp ParAtAbsOp = ILIT(170)
-tagOf_PrimOp ParAtRelOp = ILIT(171)
-tagOf_PrimOp ParAtForNowOp = ILIT(172)
-tagOf_PrimOp CopyableOp = ILIT(173)
-tagOf_PrimOp NoFollowOp = ILIT(174)
+tagOf_PrimOp WriteForeignObjOp = ILIT(156)
+tagOf_PrimOp MakeStablePtrOp = ILIT(157)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(158)
+tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(159)
+tagOf_PrimOp ErrorIOPrimOp = ILIT(160)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(161)
+tagOf_PrimOp SeqOp = ILIT(162)
+tagOf_PrimOp ParOp = ILIT(163)
+tagOf_PrimOp ForkOp = ILIT(164)
+tagOf_PrimOp DelayOp = ILIT(165)
+tagOf_PrimOp WaitReadOp = ILIT(166)
+tagOf_PrimOp WaitWriteOp = ILIT(167)
+
+tagOf_PrimOp ParGlobalOp = ILIT(168)
+tagOf_PrimOp ParLocalOp = ILIT(169)
+tagOf_PrimOp ParAtOp = ILIT(170)
+tagOf_PrimOp ParAtAbsOp = ILIT(171)
+tagOf_PrimOp ParAtRelOp = ILIT(172)
+tagOf_PrimOp ParAtForNowOp = ILIT(173)
+tagOf_PrimOp CopyableOp = ILIT(174)
+tagOf_PrimOp NoFollowOp = ILIT(175)
tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
@@ -597,6 +599,7 @@ allThePrimOps
ReadIVarOp,
WriteIVarOp,
MakeForeignObjOp,
+ WriteForeignObjOp,
MakeStablePtrOp,
DeRefStablePtrOp,
ReallyUnsafePtrEqualityOp,
@@ -1147,7 +1150,7 @@ primOpInfo WaitWriteOp
%************************************************************************
%* *
-\subsubsection[PrimOps-makeForeignObj]{PrimOpInfo for Foreign Objects}
+\subsubsection[PrimOps-ForeignObj]{PrimOpInfo for Foreign Objects}
%* *
%************************************************************************
@@ -1164,7 +1167,7 @@ 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
-The only function defined over @ForeignObj@s is:
+A @ForeignObj@ is created by the @makeForeignObj#@ primitive:
\begin{pseudocode}
makeForeignObj# :: Addr# -- foreign object
@@ -1172,6 +1175,7 @@ makeForeignObj# :: Addr# -- foreign object
-> StateAndForeignObj# _RealWorld# ForeignObj#
\end{pseudocode}
+
\begin{code}
primOpInfo MakeForeignObjOp
= AlgResult SLIT("makeForeignObj#") []
@@ -1179,6 +1183,34 @@ primOpInfo MakeForeignObjOp
stateAndForeignObjPrimTyCon [realWorldTy]
\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}).
+
+\begin{pseudocode}
+writeForeignObj# :: ForeignObj# -- foreign object
+ -> Addr# -- new data value
+ -> StateAndForeignObj# _RealWorld# ForeignObj#
+\end{pseudocode}
+
+\begin{code}
+primOpInfo WriteForeignObjOp
+ = let {
+ s = alphaTy; s_tv = alphaTyVar
+ } in
+ PrimResult SLIT("writeForeignObj#") [s_tv]
+ [foreignObjPrimTy, addrPrimTy, mkStatePrimTy s]
+ statePrimTyCon VoidRep [s]
+\end{code}
+
%************************************************************************
%* *
\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for ``stable pointers''}
@@ -1411,6 +1443,7 @@ 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
@@ -1557,7 +1590,8 @@ fragilePrimOp :: PrimOp -> Bool
fragilePrimOp ParOp = True
fragilePrimOp ForkOp = True
fragilePrimOp SeqOp = True
-fragilePrimOp MakeForeignObjOp = True -- SOF
+fragilePrimOp MakeForeignObjOp = True -- SOF
+fragilePrimOp WriteForeignObjOp = True -- SOF
fragilePrimOp MakeStablePtrOp = True
fragilePrimOp DeRefStablePtrOp = True -- ??? JSM & ADR
@@ -1629,6 +1663,7 @@ primOpNeedsWrapper DoubleEncodeOp = True
primOpNeedsWrapper DoubleDecodeOp = True
primOpNeedsWrapper MakeForeignObjOp = True
+primOpNeedsWrapper WriteForeignObjOp = True
primOpNeedsWrapper MakeStablePtrOp = True
primOpNeedsWrapper DeRefStablePtrOp = True
diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs
index 32f20e9e1f5a..626762de9932 100644
--- a/ghc/compiler/reader/Lex.lhs
+++ b/ghc/compiler/reader/Lex.lhs
@@ -531,7 +531,7 @@ is_sym c#=
'&'# -> True; '*'# -> True; '+'# -> True; '.'# -> True;
'/'# -> True; '<'# -> True; '='# -> True; '>'# -> True;
'?'# -> True; '\\'# -> True; '^'# -> True; '|'# -> True;
- '-'# -> True; '~'# -> True; _ -> False }
+ '-'# -> True; '~'# -> True; '@'# -> True; _ -> False }
--isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 3024b8e6b3f5..453fda3343de 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -32,7 +32,9 @@ import HsPragmas ( noGenPragmas )
import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl),
RdrName, rdrNameOcc
)
-import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, availName, availNames, addAvailToNameSet )
+import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn,
+ availName, availNames, addAvailToNameSet, pprAvail
+ )
import RnSource ( rnHsType )
import RnMonad
import ParseIface ( parseIface )
@@ -275,6 +277,7 @@ importDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
importDecl name necessity
= checkSlurped name `thenRn` \ already_slurped ->
if already_slurped then
+ -- traceRn (ppSep [ppStr "Already slurped:", ppr PprDebug name]) `thenRn_`
returnRn Nothing -- Already dealt with
else
if isWiredInName name then
@@ -336,37 +339,45 @@ that we know just what instances to bring into scope.
\begin{code}
getWiredInDecl name
- = -- Force in the home module in case it has instance decls for
- -- the thing we are interested in
- (if not is_tycon || mod == gHC__ then
- returnRn () -- Mini hack 1: no point for non-tycons; and if we
- -- do this we find PrelNum trying to import PackedString,
- -- because PrelBase's .hi file mentions PackedString.unpackString
- -- But PackedString.hi isn't built by that point!
- --
- -- Mini hack 2; GHC is guaranteed not to have
- -- instance decls, so it's a waste of time
- -- to read it
+ = get_wired `thenRn` \ avail ->
+ recordSlurp Nothing avail `thenRn_`
+
+ -- Force in the home module in case it has instance decls for
+ -- the thing we are interested in.
+ --
+ -- Mini hack 1: no point for non-tycons/class; and if we
+ -- do this we find PrelNum trying to import PackedString,
+ -- because PrelBase's .hi file mentions PackedString.unpackString
+ -- But PackedString.hi isn't built by that point!
+ --
+ -- Mini hack 2; GHC is guaranteed not to have
+ -- instance decls, so it's a waste of time to read it
+ --
+ -- NB: We *must* look at the availName of the slurped avail,
+ -- not the name passed to getWiredInDecl! Why? Because if a data constructor
+ -- or class op is passed to getWiredInDecl we'll pull in the whole data/class
+ -- decl, and recordSlurp will record that fact. But since the data constructor
+ -- isn't a tycon/class we won't force in the home module. And even if the
+ -- type constructor/class comes along later, loadDecl will say that it's already
+ -- been slurped, so getWiredInDecl won't even be called. Pretty obscure bug, this was.
+ let
+ main_name = availName avail
+ main_is_tc = case avail of { AvailTC _ _ -> True; Avail _ -> False }
+ (mod,_) = modAndOcc main_name
+ doc_str = ppSep [ppPStr SLIT("Need home module for wired in thing"), ppr PprDebug name]
+ in
+ (if not main_is_tc || mod == gHC__ then
+ returnRn ()
else
loadInterface doc_str mod `thenRn_`
returnRn ()
) `thenRn_`
- get_wired `thenRn` \ avail ->
- recordSlurp Nothing avail `thenRn_`
returnRn Nothing -- No declaration to process further
where
- doc_str = ppSep [ppPStr SLIT("Need home module for wired in thing"), ppr PprDebug name]
- (mod,_) = modAndOcc name
- maybe_wired_in_tycon = maybeWiredInTyConName name
- is_tycon = maybeToBool maybe_wired_in_tycon
- maybe_wired_in_id = maybeWiredInIdName name
- Just the_tycon = maybe_wired_in_tycon
- Just the_id = maybe_wired_in_id
get_wired | is_tycon -- ... a type constructor
= get_wired_tycon the_tycon
- -- Else, must be a wired-in-Id
| (isDataCon the_id) -- ... a wired-in data constructor
= get_wired_tycon (dataConTyCon the_id)
@@ -374,6 +385,12 @@ getWiredInDecl name
| otherwise -- ... a wired-in non data-constructor
= get_wired_id the_id
+ maybe_wired_in_tycon = maybeWiredInTyConName name
+ is_tycon = maybeToBool maybe_wired_in_tycon
+ maybe_wired_in_id = maybeWiredInIdName name
+ Just the_tycon = maybe_wired_in_tycon
+ Just the_id = maybe_wired_in_id
+
get_wired_id id
= addImplicitOccsRn (nameSetToList id_mentioned) `thenRn_`
@@ -406,7 +423,8 @@ checkSlurped name
returnRn (name `elemNameSet` slurped_names)
recordSlurp maybe_version avail
- = getIfacesRn `thenRn` \ ifaces ->
+ = -- traceRn (ppSep [ppStr "Record slurp:", pprAvail PprDebug avail]) `thenRn_`
+ getIfacesRn `thenRn` \ ifaces ->
let
Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts inst_mods = ifaces
new_slurped_names = addAvailToNameSet slurped_names avail
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 5d29108b737d..8a3ebf69bb82 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -468,7 +468,6 @@ addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down
| otherwise
= readMutVarSST occs_var `thenSST` \ occs ->
--- pprTrace "Add occurrence:" (ppr PprDebug name) $
writeMutVarSST occs_var ((name,necessity) : occs) `thenSST_`
returnSST name
where
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 0692bd80a49e..d49604adaace 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -1291,27 +1291,13 @@ specExpr :: CoreExpr
-- expression.
specExpr (Var v) args
- = specId v $ \ lookupId v `thenSM` \ vlookup ->
- case vlookup of
- Lifted vl vu
- -> -- Binding has been lifted, need to extract un-lifted value
- -- NB: a function binding will never be lifted => args always null
- -- i.e. no call instance required or call to be constructed
- ASSERT (null args)
- returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl))
-
- NoLift vatom@(VarArg new_v)
- -> mapSM specOutArg args `thenSM` \ arg_info ->
- mkCallInstance v new_v arg_info `thenSM` \ call_uds ->
- mkCall new_v arg_info `thenSM` \ call ->
- let
- call mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos])
- uds = unionUDList [call_uds,
- singleFvUDs vatom,
- unionUDList [uds | (_,uds,_) <- arg_info]
- ]
- in
- returnSM (call, {- tickSpecCall speced -} uds)
+ = specId v $ \ v_arg ->
+ case v_arg of
+ LitArg lit -> ASSERT( null args )
+ returnSM (Lit lit, emptyUDs)
+
+ VarArg new_v -> mkCallInstance v new_v args `thenSM` \ uds ->
+ returnSM (mkGenApp (Var new_v) args, uds)
specExpr expr@(Lit _) null_args
= ASSERT (null null_args)
@@ -1354,9 +1340,8 @@ specPrimOp :: PrimOp
specExpr (App fun arg) args
- = -- If TyArg, arg will be processed; otherwise, left alone
- specArg arg `thenSM` \ new_arg ->
- specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
+ = specArg arg `thenSM` \ new_arg ->
+ specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
returnSM (expr, uds)
specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
@@ -1564,18 +1549,18 @@ partition_args args
----------
specId :: Id
- -> (Id -> SpecM (CoreExpr, UsageDetails))
+ -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
-> SpecM (CoreExpr, UsageDetails)
specId v
= lookupId v `thenSM` \ vlookup ->
case vlookup of
Lifted vl vu
- -> thing_inside vu `thenSM` \ (expr, uds) ->
+ -> thing_inside (VarArg vu) `thenSM` \ (expr, uds) ->
returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds)
NoLift vatom
- -> thing_inside vatom `thenSM` \ (expr, uds) ->
+ -> thing_inside vatom `thenSM` \ (expr, uds) ->
returnSM (expr, singleFvUDs vatom `unionUDs` uds)
specArg :: CoreArg
@@ -1933,7 +1918,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars ->
let
-- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
- -- which correspond to unspeciailsed args
+ -- which correspond to unspecialised args
arg_tys :: [Type]
(_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
@@ -2060,246 +2045,53 @@ mkCallInstance :: Id
-> [CoreArg]
-> SpecM UsageDetails
-mkCallInstance id new_id []
- = returnSM emptyUDs
-
mkCallInstance id new_id args
-
- -- No specialised versions for "error" and friends are req'd.
- -- This is a special case in core lint etc.
-
- | isBottomingId id
+ | null args || -- No args at all
+ isBottomingId id || -- No point in specialising "error" and friends
+ -- even at unboxed types
+ idWantsToBeINLINEd id || -- It's going to be inlined anyway
+ not enough_args || -- Not enough type and dict args
+ not interesting_overloading -- Overloaded types are just tyvars
= returnSM emptyUDs
- -- No call instances for SuperDictSelIds
- -- These are a special case in mkCall
-
- | maybeToBool (isSuperDictSelId_maybe id)
- = returnSM emptyUDs
-
- -- There are also no call instances for ClassOpIds
- -- However, we need to process it to get any second-level call
- -- instances for a ConstMethodId extracted from its SpecEnv
-
| otherwise
- = let
- (tyvars, class_tyvar_pairs) = getIdOverloading id
- constrained_tyvars = map snd class_tyvar_pairs -- May contain dups
- constraint_vec = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
+ = returnSM (singleCI new_id spec_tys dicts)
- arg_res = take_type_args tyvars class_tyvar_pairs args
- enough_args = maybeToBool arg_res
-
-
- (Just (tys, dicts, rest_args)) = arg_res
-
- record_spec id tys
- = (record, lookup, spec_tys)
- where
- spec_tys = specialiseCallTys constraint_vec tys
-
- record = any (not . isTyVarTy) (catMaybes spec_tys)
-
- lookup = lookupSpecEnv (getIdSpecialisation id) tys
- in
- if (not enough_args) then
- pprTrace "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
- (ppCat (ppr PprDebug id : map (ppr_arg PprDebug) args)) $
- returnSM emptyUDs
-
- else
- case record_spec id tys of
- (False, _, _)
- -> -- pprTrace "CallInst:NotReqd\n"
- -- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)])
- (returnSM emptyUDs)
-
- (True, Nothing, spec_tys)
- -> if isClassOpId id then -- No CIs for class ops, dfun will give SPEC inst
- returnSM emptyUDs
- else
- -- pprTrace "CallInst:Reqd\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
- -- ppCat [ppPStr SLIT("CI"), ppCat (map (pprMaybeTy PprDebug) spec_tys),
- -- ppCat (map (ppr PprDebug) dicts)]])
- (returnSM (singleCI new_id spec_tys dicts))
-
- (True, Just (spec_id, tys_left, toss), _)
- -> if maybeToBool (isConstMethodId_maybe spec_id) then
- -- If we got a const method spec_id see if further spec required
- -- NB: const method is top-level so spec_id will not be cloned
- case record_spec spec_id tys_left of
- (False, _, _)
- -> -- pprTrace "CallInst:Exists\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
- -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id,
- -- ppr PprDebug (tys_left ++ drop toss dicts)]])
- (returnSM emptyUDs)
-
- (True, Nothing, spec_tys)
- -> -- pprTrace "CallInst:Exists:Reqd\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
- -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id,
- -- ppr PprDebug (tys_left ++ drop toss dicts)],
- -- ppCat [ppPStr SLIT("CI"), ppCat (map (pprMaybeTy PprDebug) spec_tys),
- -- ppCat (map (ppr PprDebug) (drop toss dicts))]])
- (returnSM (singleCI spec_id spec_tys (drop toss dicts)))
-
- (True, Just (spec_spec_id, tys_left_left, toss_toss), _)
- -> -- pprTrace "CallInst:Exists:Exists\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
- -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id,
- -- ppr PprDebug (tys_left ++ drop toss dicts)],
- -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_spec_id,
- -- ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]])
- (returnSM emptyUDs)
-
- else
- -- pprTrace "CallInst:Exists\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
- -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id,
- -- ppr PprDebug (tys_left ++ drop toss dicts)]])
- (returnSM emptyUDs)
-
-
-take_type_args (_:tyvars) class_tyvar_pairs (TyArg ty : args)
- = case (take_type_args tyvars class_tyvar_pairs args) of
- Nothing -> Nothing
+ where
+ (tyvars, class_tyvar_pairs) = getIdOverloading id
+ constrained_tyvars = map snd class_tyvar_pairs -- May contain dups
+ constraint_vec = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
+
+ arg_res = take_type_args tyvars class_tyvar_pairs args
+ enough_args = maybeToBool arg_res
+ (Just (tys, dicts, rest_args)) = arg_res
+
+ interesting_overloading = any (not . isTyVarTy) (catMaybes spec_tys)
+ spec_tys = specialiseCallTys constraint_vec tys
+
+ ----------------- Rather a gruesome help-function ---------------
+ take_type_args (_:tyvars) (TyArg ty : args)
+ = case (take_type_args tyvars args) of
+ Nothing -> Nothing
Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
-take_type_args (_:tyvars) class_tyvar_pairs [] = Nothing
+ take_type_args (_:tyvars) [] = Nothing
-take_type_args [] class_tyvar_pairs args
+ take_type_args [] args
= case (take_dict_args class_tyvar_pairs args) of
Nothing -> Nothing
Just (dicts, others) -> Just ([], dicts, others)
-take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict
+ take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict
= case (take_dict_args class_tyvar_pairs args) of
Nothing -> Nothing
Just (dicts, others) -> Just (dict:dicts, others)
-take_dict_args (_:class_tyvar_pairs) [] = Nothing
+ take_dict_args (_:class_tyvar_pairs) args = Nothing
-take_dict_args [] args = Just ([], args)
+ take_dict_args [] args = Just ([], args)
\end{code}
-\begin{code}
-mkCall :: Id
- -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
- -> SpecM CoreExpr
-
-mkCall new_id arg_infos = returnSM (
-
-{-
- | maybeToBool (isSuperDictSelId_maybe new_id)
- && any isUnboxedType ty_args
- -- No specialisations for super-dict selectors
- -- Specialise unboxed calls to SuperDictSelIds by extracting
- -- the super class dictionary directly form the super class
- -- NB: This should be dead code since all uses of this dictionary should
- -- have been specialised. We only do this to keep core-lint happy.
- = let
- Just (_, super_class) = isSuperDictSelId_maybe new_id
- super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
- Nothing -> panic "Specialise:mkCall:SuperDictId"
- Just id -> id
- in
- returnSM (False, Var super_dict_id)
-
- | otherwise
- = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
- Nothing -> checkUnspecOK new_id ty_args (
- returnSM (False, unspec_call)
- )
-
- Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
- -> let
- -- It may be necessary to specialsie a constant method spec_id again
- (spec_id, tys_left, dicts_to_toss) =
- case (maybeToBool (isConstMethodId_maybe spec_id_1),
- lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
- (False, _ ) -> spec_1_details
- (True, Nothing) -> spec_1_details
- (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
- -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
-
- args_left = toss_dicts dicts_to_toss val_args
- in
- checkSpecOK new_id ty_args spec_id tys_left (
-
- -- The resulting spec_id may be a top-level unboxed value
- -- This can arise for:
- -- 1) constant method values
- -- eq: class Num a where pi :: a
- -- instance Num Double# where pi = 3.141#
- -- 2) specilised overloaded values
- -- eq: i1 :: Num a => a
- -- i1 Int# d.Num.Int# ==> i1.Int#
- -- These top level defns should have been lifted.
- -- We must add code to unlift such a spec_id.
-
- if isUnboxedType (idType spec_id) then
- ASSERT (null tys_left && null args_left)
- if toplevelishId spec_id then
- liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
- returnSM (True, bindUnlift lift_spec_id unlift_spec_id
- (Var unlift_spec_id))
- else
- pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
- (ppCat [ppr PprDebug new_id,
- ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args),
- ppPStr SLIT("==>"),
- ppr PprDebug spec_id])
- else
- let
- (vals_left, _, unlifts_left) = unzip3 args_left
- applied_tys = mkTyApp (Var spec_id) tys_left
- applied_vals = mkGenApp applied_tys vals_left
- in
- returnSM (True, applyBindUnlifts unlifts_left applied_vals)
- )
- where
- (tys_and_vals, _, unlifts) = unzip3 args
- unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
-
-
- -- ty_args is the types at the front of the arg list
- -- val_args is the rest of the arg-list
-
- (ty_args, val_args) = get args
- where
- get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
- get args = ([], args)
-
-
- -- toss_dicts chucks away dict args, checking that they ain't types!
- toss_dicts 0 args = args
- toss_dicts n ((a,_,_) : args)
- | isValArg a = toss_dicts (n-1) args
-
-\end{code}
-
-\begin{code}
-checkUnspecOK :: Id -> [Type] -> a -> a
-checkUnspecOK check_id tys
- = if isLocallyDefined check_id && any isUnboxedType tys
- then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
- (ppCat [ppr PprDebug check_id,
- ppInterleave ppNil (map (pprParendGenType PprDebug) tys)])
- else id
-
-checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
-checkSpecOK check_id tys spec_id tys_left
- = if any isUnboxedType tys_left
- then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
- (ppAboves [ppCat [ppr PprDebug check_id,
- ppInterleave ppNil (map (pprParendGenType PprDebug) tys)],
- ppCat [ppr PprDebug spec_id,
- ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
- else id
--}
-\end{code}
\begin{code}
mkTyConInstance :: Id
@@ -2374,8 +2166,7 @@ type SpecM result
-> UniqSupply
-> result
-initSM m uniqs
- = m nullTyVarEnv nullIdEnv uniqs
+initSM m uniqs = m nullTyVarEnv nullIdEnv uniqs
returnSM :: a -> SpecM a
thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
@@ -2404,7 +2195,7 @@ newSpecIds :: [Id] -- The id of which to make a specialised version
newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
= [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
- | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ]
+ | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ]
where
uniqs = getUniques (length new_ids) us
spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
@@ -2592,3 +2383,124 @@ mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))
-}
\end{code}
+
+
+
+===================== OLD CODE, scheduled for deletion =================
+
+\begin{code}
+{-
+mkCall :: Id
+ -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
+ -> SpecM CoreExpr
+
+mkCall new_id arg_infos = returnSM (
+
+ | maybeToBool (isSuperDictSelId_maybe new_id)
+ && any isUnboxedType ty_args
+ -- No specialisations for super-dict selectors
+ -- Specialise unboxed calls to SuperDictSelIds by extracting
+ -- the super class dictionary directly form the super class
+ -- NB: This should be dead code since all uses of this dictionary should
+ -- have been specialised. We only do this to keep core-lint happy.
+ = let
+ Just (_, super_class) = isSuperDictSelId_maybe new_id
+ super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
+ Nothing -> panic "Specialise:mkCall:SuperDictId"
+ Just id -> id
+ in
+ returnSM (False, Var super_dict_id)
+
+ | otherwise
+ = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
+ Nothing -> checkUnspecOK new_id ty_args (
+ returnSM (False, unspec_call)
+ )
+
+ Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
+ -> let
+ -- It may be necessary to specialsie a constant method spec_id again
+ (spec_id, tys_left, dicts_to_toss) =
+ case (maybeToBool (isConstMethodId_maybe spec_id_1),
+ lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
+ (False, _ ) -> spec_1_details
+ (True, Nothing) -> spec_1_details
+ (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
+ -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
+
+ args_left = toss_dicts dicts_to_toss val_args
+ in
+ checkSpecOK new_id ty_args spec_id tys_left (
+
+ -- The resulting spec_id may be a top-level unboxed value
+ -- This can arise for:
+ -- 1) constant method values
+ -- eq: class Num a where pi :: a
+ -- instance Num Double# where pi = 3.141#
+ -- 2) specilised overloaded values
+ -- eq: i1 :: Num a => a
+ -- i1 Int# d.Num.Int# ==> i1.Int#
+ -- These top level defns should have been lifted.
+ -- We must add code to unlift such a spec_id.
+
+ if isUnboxedType (idType spec_id) then
+ ASSERT (null tys_left && null args_left)
+ if toplevelishId spec_id then
+ liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
+ returnSM (True, bindUnlift lift_spec_id unlift_spec_id
+ (Var unlift_spec_id))
+ else
+ pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
+ (ppCat [ppr PprDebug new_id,
+ ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args),
+ ppPStr SLIT("==>"),
+ ppr PprDebug spec_id])
+ else
+ let
+ (vals_left, _, unlifts_left) = unzip3 args_left
+ applied_tys = mkTyApp (Var spec_id) tys_left
+ applied_vals = mkGenApp applied_tys vals_left
+ in
+ returnSM (True, applyBindUnlifts unlifts_left applied_vals)
+ )
+ where
+ (tys_and_vals, _, unlifts) = unzip3 args
+ unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
+
+
+ -- ty_args is the types at the front of the arg list
+ -- val_args is the rest of the arg-list
+
+ (ty_args, val_args) = get args
+ where
+ get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
+ get args = ([], args)
+
+
+ -- toss_dicts chucks away dict args, checking that they ain't types!
+ toss_dicts 0 args = args
+ toss_dicts n ((a,_,_) : args)
+ | isValArg a = toss_dicts (n-1) args
+
+\end{code}
+
+\begin{code}
+checkUnspecOK :: Id -> [Type] -> a -> a
+checkUnspecOK check_id tys
+ = if isLocallyDefined check_id && any isUnboxedType tys
+ then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
+ (ppCat [ppr PprDebug check_id,
+ ppInterleave ppNil (map (pprParendGenType PprDebug) tys)])
+ else id
+
+checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
+checkSpecOK check_id tys spec_id tys_left
+ = if any isUnboxedType tys_left
+ then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
+ (ppAboves [ppCat [ppr PprDebug check_id,
+ ppInterleave ppNil (map (pprParendGenType PprDebug) tys)],
+ ppCat [ppr PprDebug spec_id,
+ ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
+ else id
+-}
+\end{code}
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index e58942693524..4587e182c01b 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -366,6 +366,8 @@ we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
\begin{verbatim}
instance ... Enum (Foo ...) where
+ toEnum i = tag2con_Foo i
+
enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
-- or, really...
@@ -390,11 +392,17 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
gen_Enum_binds :: TyCon -> RdrNameMonoBinds
gen_Enum_binds tycon
- = enum_from `AndMonoBinds`
+ = to_enum `AndMonoBinds`
+ enum_from `AndMonoBinds`
enum_from_then `AndMonoBinds`
from_enum
where
tycon_loc = getSrcLoc tycon
+
+ to_enum
+ = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
+ mk_easy_App (tag2con_RDR tycon) [a_RDR]
+
enum_from
= mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs
index ab54af778457..21f61fda2012 100644
--- a/ghc/compiler/utils/FastString.lhs
+++ b/ghc/compiler/utils/FastString.lhs
@@ -134,10 +134,10 @@ concatFS :: [FastString] -> FastString
concatFS ls = mkFastString (concat (map (unpackFS) ls)) -- ToDo: do better
headFS :: FastString -> Char
-headFS (FastString _ l# ba#) =
- if l# ># 0# then C# (indexCharArray# ba# 0#) else error "headFS: empty FS"
-headFS (CharStr a# l#) =
- if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error "headFS: empty FS"
+headFS f@(FastString _ l# ba#) =
+ if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
+headFS f@(CharStr a# l#) =
+ if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
tailFS :: FastString -> FastString
tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
diff --git a/ghc/docs/Makefile b/ghc/docs/Makefile
index 2f99b93e634d..cf8be1f57fcd 100644
--- a/ghc/docs/Makefile
+++ b/ghc/docs/Makefile
@@ -6,6 +6,6 @@ include $(TOP)/mk/boilerplate.mk
#
export WAYS=
-SUBDIRS = users_guide install_guide release_notes state_interface
+SUBDIRS = users_guide
include $(TOP)/mk/target.mk
diff --git a/ghc/driver/ghc-asm.lprl b/ghc/driver/ghc-asm.lprl
index f24343343d40..89cc4b1ca7d1 100644
--- a/ghc/driver/ghc-asm.lprl
+++ b/ghc/driver/ghc-asm.lprl
@@ -348,9 +348,20 @@ sub mangle_asm {
# multi-line regexp matching:
local($*) = 1;
local($i, $c);
+
+
&init_TARGET_STUFF();
&init_FUNNY_THINGS();
+ # perl4 on alphas SEGVs when give ${foo} substitutions in patterns.
+ # To avoid them we declare some locals that allows to avoid using curlies.
+ local($TUS) = ${T_US};
+ local($TPOSTLBL) = ${T_POST_LBL};
+ local($TMOVEDIRVS) = ${T_MOVE_DIRVS};
+ local($TPREAPP) = ${T_PRE_APP};
+ local($TCOPYDIRVS) = ${T_COPY_DIRVS};
+ local($TDOTWORD) = ${T_DOT_WORD};
+
open(INASM, "< $in_asmf")
|| &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
open(OUTASM,"> $out_asmf")
@@ -374,10 +385,9 @@ sub mangle_asm {
$i = 0; $chkcat[0] = 'misc'; $chk[0] = '';
while (<INASM>) {
- next if $T_STABBY && /^\.stab.*${T_US}__stg_split_marker/o;
+ next if $T_STABBY && /^\.stab.*$TUS[@]?__stg_split_marker/o;
next if $T_STABBY && /^\.stab.*ghc.*c_ID/;
- next if /${T_PRE_APP}(NO_)?APP/o;
-
+ next if /$TPREAPP(NO_)?APP/o;
next if /^;/ && $TargetPlatform =~ /^hppa/;
next if /(^$|^\t\.file\t|^ # )/ && $TargetPlatform =~ /^(mips|powerpc)-/;
@@ -408,12 +418,12 @@ sub mangle_asm {
$chkcat[$i] = 'literal';
$chksymb[$i] = $1;
- } elsif ( /^${T_US}__stg_split_marker(\d+)${T_POST_LBL}$/o ) {
+ } elsif ( /^$TUS[@]?__stg_split_marker(\d+)$TPOSTLBL[@]?$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'splitmarker';
$chksymb[$i] = $1;
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_info${T_POST_LBL}$/o ) {
+ } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_info$TPOSTLBL[@]?$/o ) {
$symb = $1;
$chk[++$i] = $_;
$chkcat[$i] = 'infotbl';
@@ -423,40 +433,40 @@ sub mangle_asm {
$infochk{$symb} = $i;
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_entry${T_POST_LBL}$/o ) {
+ } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_entry$TPOSTLBL[@]?$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'slow';
$chksymb[$i] = $1;
$slowchk{$1} = $i;
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_fast\d+${T_POST_LBL}$/o ) {
+ } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_fast\d+$TPOSTLBL[@]?$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'fast';
$chksymb[$i] = $1;
$fastchk{$1} = $i;
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_closure${T_POST_LBL}$/o ) {
+ } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_closure$TPOSTLBL[@]?$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'closure';
$chksymb[$i] = $1;
$closurechk{$1} = $i;
- } elsif ( /^${T_US}ghc.*c_ID${T_POST_LBL}/o ) {
+ } elsif ( /^$TUS[@]?ghc.*c_ID$TPOSTLBL/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'consist';
- } elsif ( /^(${T_US}__gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/o ) {
+ } elsif ( /^($TUS[@]?__gnu_compiled_c|gcc2_compiled\.)$TPOSTLBL/o ) {
; # toss it
- } elsif ( /^${T_US}ErrorIO_call_count${T_POST_LBL}$/o # HACK!!!!
- || /^${T_US}[A-Za-z0-9_]+\.\d+${T_POST_LBL}$/o
- || /^${T_US}.*_CAT${T_POST_LBL}$/o # PROF: _entryname_CAT
- || /^${T_US}CC_.*_struct${T_POST_LBL}$/o # PROF: _CC_ccident_struct
- || /^${T_US}.*_done${T_POST_LBL}$/o # PROF: _module_done
- || /^${T_US}_module_registered${T_POST_LBL}$/o # PROF: _module_registered
+ } elsif ( /^$TUS[@]?ErrorIO_call_count$TPOSTLBL[@]?$/o # HACK!!!!
+ || /^$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
+ || /^$TUS[@]?_module_registered$TPOSTLBL[@]?$/o # PROF: _module_registered
) {
$chk[++$i] = $_;
$chkcat[$i] = 'data';
@@ -467,26 +477,26 @@ sub mangle_asm {
$chkcat[$i] = 'bss';
$chksymb[$i] = $1;
- } elsif ( /^${T_US}(ret_|djn_)/o ) {
+ } elsif ( /^$TUS[@]?(ret_|djn_)/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'misc';
$chksymb[$i] = '';
- } elsif ( /^${T_US}vtbl_([A-Za-z0-9_]+)${T_POST_LBL}$/o ) {
+ } elsif ( /^$TUS[@]?vtbl_([A-Za-z0-9_]+)$TPOSTLBL[@]?$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'vector';
$chksymb[$i] = $1;
$vectorchk{$1} = $i;
- } elsif ( /^${T_US}([A-Za-z0-9_]+)DirectReturn${T_POST_LBL}$/o ) {
+ } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)DirectReturn$TPOSTLBL[@]?$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'direct';
$chksymb[$i] = $1;
$directchk{$1} = $i;
- } elsif ( /^${T_US}[A-Za-z0-9_]+_upd${T_POST_LBL}$/o ) {
+ } elsif ( /^$TUS[@]?[A-Za-z0-9_]+_upd$TPOSTLBL[@]?$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'misc';
$chksymb[$i] = '';
@@ -506,7 +516,7 @@ sub mangle_asm {
$chkcat[$i] = 'toss';
$chksymb[$i] = $1;
- } elsif ( /^${T_US}[A-Za-z0-9_]/o
+ } elsif ( /^$TUS[@]?[A-Za-z0-9_]/o
&& ( $TargetPlatform !~ /^hppa/ # need to avoid local labels in this case
|| ! /^L\$\d+$/ )
&& ( $TargetPlatform !~ /^powerpc/ # ditto
@@ -515,9 +525,9 @@ sub mangle_asm {
chop($thing = $_);
print STDERR "Funny global thing?: $_"
unless $KNOWN_FUNNY_THING{$thing}
- || /^${T_US}_(PRIn|PRStart).*${T_POST_LBL}$/o # pointer reversal GC routines
- || /^${T_US}CC_.*${T_POST_LBL}$/o # PROF: _CC_ccident
- || /^${T_US}_reg.*${T_POST_LBL}$/o; # PROF: __reg<module>
+ || /^$TUS[@]?_(PRIn|PRStart).*$TPOSTLBL[@]?$/o # pointer reversal GC routines
+ || /^$TUS[@]?CC_.*$TPOSTLBL$/o # PROF: _CC_ccident ([@]? is a silly hack (see above))
+ || /^$TUS[@]?_reg.*$TPOSTLBL$/o; # PROF: __reg<module>
$chk[++$i] = $_;
$chkcat[$i] = 'misc';
$chksymb[$i] = '';
@@ -644,7 +654,7 @@ sub mangle_asm {
# On Alphas, the prologue mangling is done a little later (below)
# toss all calls to __DISCARD__
- $c =~ s/^\t(call|jbsr|jal)\s+${T_US}__DISCARD__\n//go;
+ $c =~ s/^\t(call|jbsr|jal)\s+$TUS[@]?__DISCARD__\n//go;
# MIPS: that may leave some gratuitous asm macros around
# (no harm done; but we get rid of them to be tidier)
@@ -667,16 +677,18 @@ sub mangle_asm {
# pin a funny end-thing on (for easier matching):
$c .= 'FUNNY#END#THING';
- while ( $c =~ /${T_MOVE_DIRVS}FUNNY#END#THING/o ) {
+ while ( $c =~ /$TMOVEDIRVS[@]?FUNNY#END#THING/o ) { # [@]? is a silly hack to avoid having to use curlies for T_PRE_APP
+ # (this SEGVs perl4 on alphas, you see)
+
$to_move = $1;
if ( $i < ($numchks - 1)
- && ( $to_move =~ /${T_COPY_DIRVS}/
+ && ( $to_move =~ /$TCOPYDIRVS/
|| ($TargetPlatform =~ /^hppa/ && $to_move =~ /align/ && $chkcat[$i+1] eq 'literal') )) {
$chk[$i + 1] = $to_move . $chk[$i + 1];
# otherwise they're tossed
}
- $c =~ s/${T_MOVE_DIRVS}FUNNY#END#THING/FUNNY#END#THING/o;
+ $c =~ s/$TMOVEDIRVS[@]?FUNNY#END#THING/FUNNY#END#THING/o; # [@]? is a hack (see above)
}
if ( $TargetPlatform =~ /^alpha-/ && $c =~ /^\t\.ent\s+(\S+)/ ) {
@@ -816,7 +828,7 @@ sub mangle_asm {
# entry code will be put here!
# paranoia
- if ( $chk[$infochk{$symb}] =~ /${T_DOT_WORD}\s+([A-Za-z0-9_]+_entry)$/o
+ 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}];
}
@@ -856,7 +868,7 @@ sub mangle_asm {
# references to fast-entry point.
# (questionable re hppa and mips...)
print STDERR "still has jump to fast entry point:\n$c"
- if $c =~ /${T_US}${symb}_fast/; # NB: paranoia
+ if $c =~ /$TUS[@]?$symb[@]?_fast/; # NB: paranoia
}
print OUTASM $T_HDR_entry;
@@ -1218,18 +1230,24 @@ sub rev_tbl {
local($after) = '';
local(@lines) = split(/\n/, $tbl);
local($i, $extra, $words_to_pad, $j);
-
- for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t${T_DOT_WORD}\s+/o; $i++) {
+
+ # 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++) {
$label .= $lines[$i] . "\n",
- next if $lines[$i] =~ /^[A-Za-z0-9_]+_info${T_POST_LBL}$/o
- || $lines[$i] =~ /${T_DOT_GLOBAL}/o
- || $lines[$i] =~ /^${T_US}vtbl_\S+${T_POST_LBL}$/o;
+ next if $lines[$i] =~ /^[A-Za-z0-9_]+_info$TPOSTLBL[@]?$/o
+ || $lines[$i] =~ /$TDOTGLOBAL/o
+ || $lines[$i] =~ /^$TUS[@]?vtbl_\S+$TPOSTLBL[@]?$/o;
$before .= $lines[$i] . "\n"; # otherwise...
}
if ( $TargetPlatform !~ /^hppa/ ) {
- for ( ; $i <= $#lines && $lines[$i] =~ /^\t${T_DOT_WORD}\s+/o; $i++) {
+ for ( ; $i <= $#lines && $lines[$i] =~ /^\t$TDOTWORD\s+/o; $i++) {
push(@words, $lines[$i]);
}
} else { # hppa weirdness
@@ -1287,6 +1305,10 @@ sub mini_mangle_asm_i386 {
&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")
@@ -1296,7 +1318,7 @@ sub mini_mangle_asm_i386 {
print OUTASM;
next unless
- /^${T_US}(PerformGC|StackOverflow|Yield|PerformReschedule)_wrapper${T_POST_LBL}\n/o;
+ /^$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";
}
diff --git a/ghc/includes/StgMacros.lh b/ghc/includes/StgMacros.lh
index 3732beb44d32..56d652333721 100644
--- a/ghc/includes/StgMacros.lh
+++ b/ghc/includes/StgMacros.lh
@@ -2094,7 +2094,7 @@ do { \
StorageMgrInfo.ForeignObjList = result; \
\
\
-/*fprintf(stderr,"DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \
+ /*fprintf(stderr,"DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \
result, \
result[0],result[1], \
result[2],result[3]);*/ \
@@ -2105,6 +2105,8 @@ do { \
(r) = (P_) result; \
} while (0)
+#define writeForeignObjZh(res,datum) ((PP_) ForeignObj_CLOSURE_DATA(res)) = ((P_)datum)
+
#else
#define makeForeignObjZh(r, liveness, mptr, finalise) \
do { \
@@ -2113,6 +2115,13 @@ do { \
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}
diff --git a/ghc/lib/Makefile b/ghc/lib/Makefile
index 6236c38ffaae..76e8dbfa6091 100644
--- a/ghc/lib/Makefile
+++ b/ghc/lib/Makefile
@@ -4,7 +4,7 @@
#
# Makefile for building the GHC Prelude libraries umpteen ways
#
-# $Id: Makefile,v 1.5 1997/03/14 05:30:36 sof Exp $
+# $Id: Makefile,v 1.6 1997/03/17 20:34:49 simonpj Exp $
#
#
#################################################################################
@@ -52,14 +52,15 @@ endif
# per-module flags
-ghc/PackedString_HC_OPTS = -monly-3-regs
-required/Directory_HC_OPTS = -monly-3-regs
-concurrent/Parallel_HC_OPTS = -fglasgow-exts
+ghc/PackedString_HC_OPTS += -monly-3-regs
+required/Directory_HC_OPTS += -monly-3-regs
+concurrent/Parallel_HC_OPTS += -fglasgow-exts
+required/Time_HC_OPTS += -monly-3-regs
#-----------------------------------------------------------------------------
# Dependency generation
-SRC_MKDEPENDHS_OPTS += -irequired:ghc:hbc:glaExts:concurrent
+SRC_MKDEPENDHS_OPTS += -irequired:ghc:hbc:glaExts:concurrent -I$(GHC_INCLUDE_DIR)
#-----------------------------------------------------------------------------
# Rules
diff --git a/ghc/lib/cbits/stgio.h b/ghc/lib/cbits/stgio.h
index 8c0d2cb8beb5..d6b9b02f1c22 100644
--- a/ghc/lib/cbits/stgio.h
+++ b/ghc/lib/cbits/stgio.h
@@ -59,6 +59,10 @@ 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));
diff --git a/ghc/lib/ghc/GHC.hi-boot b/ghc/lib/ghc/GHC.hi-boot
index 884bba09ace2..d751f95ec53f 100644
--- a/ghc/lib/ghc/GHC.hi-boot
+++ b/ghc/lib/ghc/GHC.hi-boot
@@ -210,6 +210,7 @@ indexAddrOffAddr#
ForeignObj#
makeForeignObj#
+ writeForeignObj#
StablePtr#
makeStablePtr#
diff --git a/ghc/lib/ghc/IOBase.lhs b/ghc/lib/ghc/IOBase.lhs
index 4a952f718ffc..8f1ad2553f8c 100644
--- a/ghc/lib/ghc/IOBase.lhs
+++ b/ghc/lib/ghc/IOBase.lhs
@@ -399,11 +399,19 @@ type Handle = MutableVar RealWorld Handle__
data Handle__
= ErrorHandle IOError
| ClosedHandle
+#ifndef PAR
| SemiClosedHandle ForeignObj (Addr, Int)
| ReadHandle ForeignObj (Maybe BufferMode) Bool
| WriteHandle ForeignObj (Maybe BufferMode) Bool
| AppendHandle ForeignObj (Maybe BufferMode) Bool
| ReadWriteHandle ForeignObj (Maybe BufferMode) Bool
+#else
+ | SemiClosedHandle Addr (Addr, Int)
+ | ReadHandle Addr (Maybe BufferMode) Bool
+ | WriteHandle Addr (Maybe BufferMode) Bool
+ | AppendHandle Addr (Maybe BufferMode) Bool
+ | ReadWriteHandle Addr (Maybe BufferMode) Bool
+#endif
-- Standard Instances as defined by the Report..
diff --git a/ghc/lib/ghc/IOHandle.lhs b/ghc/lib/ghc/IOHandle.lhs
index 50e1300c98ff..a3f64ceb6eeb 100644
--- a/ghc/lib/ghc/IOHandle.lhs
+++ b/ghc/lib/ghc/IOHandle.lhs
@@ -23,7 +23,7 @@ import IOBase
import PrelTup
import PrelBase
import GHC
-import Foreign ( makeForeignObj )
+import Foreign ( makeForeignObj, writeForeignObj )
import PrelList (span)
#if defined(__CONCURRENT_HASKELL__)
import ConcBase
@@ -68,7 +68,11 @@ writeHandle h v = stToIO (writeVar h v)
%*********************************************************
\begin{code}
+#ifndef PAR
filePtr :: Handle__ -> ForeignObj
+#else
+filePtr :: Handle__ -> Addr
+#endif
filePtr (SemiClosedHandle fp _) = fp
filePtr (ReadHandle fp _ _) = fp
filePtr (WriteHandle fp _ _) = fp
@@ -116,8 +120,13 @@ stdin = unsafePerformPrimIO (
_ccall_ getLock (``stdin''::Addr) 0 >>= \ rc ->
(case rc of
0 -> new_handle ClosedHandle
- 1 -> makeForeignObj (``stdin''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
+ 1 ->
+#ifndef PAR
+ makeForeignObj (``stdin''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
new_handle (ReadHandle fp Nothing False)
+#else
+ new_handle (ReadHandle ``stdin'' Nothing False)
+#endif
_ -> constructError "stdin" >>= \ ioError ->
new_handle (ErrorHandle ioError)
) >>= \ handle ->
@@ -130,8 +139,13 @@ stdout = unsafePerformPrimIO (
_ccall_ getLock (``stdout''::Addr) 1 >>= \ rc ->
(case rc of
0 -> new_handle ClosedHandle
- 1 -> makeForeignObj (``stdout''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
+ 1 ->
+#ifndef PAR
+ makeForeignObj (``stdout''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
new_handle (WriteHandle fp Nothing False)
+#else
+ new_handle (WriteHandle ``stdout'' Nothing False)
+#endif
_ -> constructError "stdout" >>= \ ioError ->
new_handle (ErrorHandle ioError)
) >>= \ handle ->
@@ -144,8 +158,13 @@ stderr = unsafePerformPrimIO (
_ccall_ getLock (``stderr''::Addr) 1 >>= \ rc ->
(case rc of
0 -> new_handle ClosedHandle
- 1 -> makeForeignObj (``stderr''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
+ 1 ->
+#ifndef PAR
+ makeForeignObj (``stderr''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
new_handle (WriteHandle fp (Just NoBuffering) False)
+#else
+ new_handle (WriteHandle ``stderr'' (Just NoBuffering) False)
+#endif
_ -> constructError "stderr" >>= \ ioError ->
new_handle (ErrorHandle ioError)
) >>= \ handle ->
@@ -170,8 +189,12 @@ openFile :: FilePath -> IOMode -> IO Handle
openFile f m =
stToIO (_ccall_ openFile f m') >>= \ ptr ->
if ptr /= ``NULL'' then
- stToIO (makeForeignObj ptr ((``&freeFile'')::Addr)) >>= \ fp ->
+#ifndef PAR
+ makeForeignObj ptr ((``&freeFile'')::Addr) `thenIO_Prim` \ fp ->
newHandle (htype fp Nothing False)
+#else
+ newHandle (htype ptr Nothing False)
+#endif
else
stToIO (constructError "openFile") >>= \ ioError@(IOError hn iot msg) ->
let
@@ -226,11 +249,12 @@ hClose :: Handle -> IO ()
hClose handle =
readHandle handle >>= \ htype ->
- writeHandle handle ClosedHandle >>
case htype of
ErrorHandle ioError ->
+ writeHandle handle htype >>
fail ioError
ClosedHandle ->
+ writeHandle handle htype >>
ioe_closedHandle handle
SemiClosedHandle fp (buf,_) ->
(if buf /= ``NULL'' then
@@ -245,19 +269,30 @@ hClose handle =
has been performed, the ForeignObj embedded in the Handle
is still lying around in the heap, so care is taken
to avoid closing the file object when the ForeignObj
- is finalised. (see freeFile()) -}
+ is finalised. -}
if rc == 0 then
- return ()
+#ifndef PAR
+ -- Mark the foreign object data value as gone to the finaliser (freeFile())
+ writeForeignObj fp ``NULL'' `thenIO_Prim` \ () ->
+#endif
+ writeHandle handle ClosedHandle
else
+ writeHandle handle htype >>
constructErrorAndFail "hClose"
else
- return ()
+ writeHandle handle htype
other ->
- _ccall_ closeFile (filePtr other) `thenIO_Prim` \ rc ->
+ let fp = filePtr other in
+ _ccall_ closeFile fp `thenIO_Prim` \ rc ->
if rc == 0 then
- return ()
+#ifndef PAR
+ -- Mark the foreign object data
+ writeForeignObj fp ``NULL'' `thenIO_Prim` \ () ->
+#endif
+ writeHandle handle ClosedHandle
else
+ writeHandle handle htype >>
constructErrorAndFail "hClose"
\end{code}
@@ -427,7 +462,11 @@ hSetBuffering handle mode =
BlockBuffering Nothing -> -2
BlockBuffering (Just n) -> n
+#ifndef PAR
hcon :: Handle__ -> (ForeignObj -> (Maybe BufferMode) -> Bool -> Handle__)
+#else
+ hcon :: Handle__ -> (Addr -> (Maybe BufferMode) -> Bool -> Handle__)
+#endif
hcon (ReadHandle _ _ _) = ReadHandle
hcon (WriteHandle _ _ _) = WriteHandle
hcon (AppendHandle _ _ _) = AppendHandle
diff --git a/ghc/lib/glaExts/Foreign.lhs b/ghc/lib/glaExts/Foreign.lhs
index 8273434390e9..81abc4f13dc0 100644
--- a/ghc/lib/glaExts/Foreign.lhs
+++ b/ghc/lib/glaExts/Foreign.lhs
@@ -79,12 +79,21 @@ instance CReturnable () -- Why, exactly?
instance CCallable ForeignObj
instance CCallable ForeignObj#
-eqForeignObj :: ForeignObj -> ForeignObj -> Bool
-makeForeignObj :: Addr -> Addr -> PrimIO ForeignObj
+eqForeignObj :: ForeignObj -> ForeignObj -> Bool
+makeForeignObj :: Addr -> Addr -> PrimIO ForeignObj
+writeForeignObj :: ForeignObj -> Addr -> PrimIO ()
-makeForeignObj (A# obj) (A# finaliser) = ST $ \ (S# s#) ->
+{- derived op - attaching a free() finaliser to a malloc() allocated reference. -}
+makeMallocPtr :: Addr -> PrimIO ForeignObj
+
+makeForeignObj (A# obj) (A# finaliser) = ST ( \ (S# s#) ->
case makeForeignObj# obj finaliser s# of
- StateAndForeignObj# s1# fo# -> (ForeignObj fo#, S# s1#)
+ StateAndForeignObj# s1# fo# -> (ForeignObj fo#, S# s1#))
+
+writeForeignObj (ForeignObj fo#) (A# datum#) = ST ( \ (S# s#) ->
+ case writeForeignObj# fo# datum# s# of { s1# -> ((), S# s1#) } )
+
+makeMallocPtr a = makeForeignObj a (``&free''::Addr)
eqForeignObj mp1 mp2
= unsafePerformPrimIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int)
diff --git a/ghc/lib/required/Directory.lhs b/ghc/lib/required/Directory.lhs
index e9f70e96d9e9..d7fdf7da88d5 100644
--- a/ghc/lib/required/Directory.lhs
+++ b/ghc/lib/required/Directory.lhs
@@ -1,8 +1,7 @@
%
% (c) The AQUA Project, Glasgow University, 1994-1997
%
-
-\section[Directory]{Module @Directory@}
+\section[Directory]{Directory interface}
A directory contains a series of entries, each of which is a named
reference to a file system object (file, directory etc.). Some
@@ -18,23 +17,36 @@ some operating systems, it may also be possible to have paths which
are relative to the current directory.
\begin{code}
-module Directory (
--- Permissions(Permissions),
- createDirectory, removeDirectory, removeFile,
- renameDirectory, renameFile, getDirectoryContents,
- getCurrentDirectory, setCurrentDirectory
-{-
- ,doesFileExist, doesDirectoryExist,
- getPermissions, setPermissions,
+{-# OPTIONS -#include <sys/stat.h> #-}
+module Directory
+ (
+ Permissions(Permissions),
+
+ createDirectory,
+ removeDirectory,
+ renameDirectory,
+ getDirectoryContents,
+ getCurrentDirectory,
+ setCurrentDirectory,
+
+ removeFile,
+ renameFile,
+
+ doesFileExist,
+ doesDirectoryExist,
+ getPermissions,
+ setPermissions,
getModificationTime
--}
- ) where
+ ) where
-import Prelude
+import PrelBase
import Foreign
import IOBase
-import STBase ( PrimIO )
-import PackedString ( packCBytesST, unpackPS )
+import STBase
+import ArrBase
+import PackedString ( packCBytesST, unpackPS, psToByteArrayST )
+import Time ( ClockTime(..) )
+
\end{code}
%*********************************************************
@@ -52,6 +64,11 @@ renameFile :: FilePath -> FilePath -> IO ()
getDirectoryContents :: FilePath -> IO [FilePath]
getCurrentDirectory :: IO FilePath
setCurrentDirectory :: FilePath -> IO ()
+doesFileExist :: FilePath -> IO Bool
+doesDirectoryExist :: FilePath -> IO Bool
+getPermissions :: FilePath -> IO Permissions
+setPermissions :: FilePath -> Permissions -> IO ()
+getModificationTime :: FilePath -> IO ClockTime
\end{code}
@@ -61,8 +78,9 @@ setCurrentDirectory :: FilePath -> IO ()
%* *
%*********************************************************
-The @Permissions@ type is used to record whether certain operations are permissible on a
-file/directory:
+The @Permissions@ type is used to record whether certain
+operations are permissible on a file/directory:
+[to whom? - owner/group/world - the Report don't say much]
\begin{code}
data Permissions
@@ -70,7 +88,6 @@ data Permissions
readable, writeable,
executable, searchable :: Bool
} deriving (Eq, Ord, Read, Show)
-
\end{code}
%*********************************************************
@@ -410,25 +427,26 @@ setCurrentDirectory path =
\begin{code}
-{-
-doesFileExist :: FilePath -> IO Bool
+--doesFileExist :: FilePath -> IO Bool
doesFileExist name =
psToByteArrayST name `thenIO_Prim` \ path ->
_ccall_ access path (``F_OK''::Int) `thenIO_Prim` \ rc ->
return (rc == 0)
-doesDirectoryExist :: FilePath -> IO Bool
-doesDirectoryExist name =
- (getFileStatus >>= isDirectory) `catch` (\ _ -> return False)
+--doesDirectoryExist :: FilePath -> IO Bool
+doesDirectoryExist name =
+ (getFileStatus name >>= \ st -> return (isDirectory st))
+ `catch`
+ (\ _ -> return False)
-getModificationTime :: FilePath -> IO Bool
+--getModificationTime :: FilePath -> IO ClockTime
getModificationTime name =
- getFileStatus >>= \ st ->
- return (modificationTime st)
+ getFileStatus name >>= \ st ->
+ modificationTime st
-getPermissions :: FilePath -> IO Permissions
+--getPermissions :: FilePath -> IO Permissions
getPermissions name =
- getFileStatus >>= \ st ->
+ getFileStatus name >>= \ st ->
let
fm = fileMode st
isect v = intersectFileMode v fm == v
@@ -441,5 +459,99 @@ getPermissions name =
searchable = not (isRegularFile st) && isect ownerExecuteMode
}
)
--}
+
+--setPermissions :: FilePath -> Permissions -> IO ()
+setPermissions name (Permissions r w e s) =
+ let
+ read# = case (if r then ownerReadMode else ``0'') of { W# x# -> x# }
+ write# = case (if w then ownerWriteMode else ``0'') of { W# x# -> x# }
+ exec# = case (if e || s then ownerExecuteMode else ``0'') of { W# x# -> x# }
+
+ mode = I# (word2Int# (read# `or#` write# `or#` exec#))
+ in
+ psToByteArrayST name `thenIO_Prim` \ path ->
+ _ccall_ chmod path mode `thenIO_Prim` \ rc ->
+ if rc == 0 then
+ return ()
+ else
+ fail (IOError Nothing SystemError "Directory.setPermissions")
+
+\end{code}
+
+
+(Sigh)..copied from Posix.Files to avoid dep. on posix library
+
+\begin{code}
+type FileStatus = ByteArray Int
+
+getFileStatus :: FilePath -> IO FileStatus
+getFileStatus name =
+ psToByteArrayST name `thenIO_Prim` \ path ->
+ newCharArray (0,``sizeof(struct stat)'') `thenIO_Prim` \ bytes ->
+ _casm_ ``%r = stat(%0,(struct stat *)%1);'' path bytes
+ `thenIO_Prim` \ rc ->
+ if rc == 0 then
+ unsafeFreezeByteArray bytes `thenIO_Prim` \ stat ->
+ return stat
+ else
+ fail (IOError Nothing SystemError "Directory.getFileStatus")
+
+modificationTime :: FileStatus -> IO ClockTime
+modificationTime stat =
+ malloc1 `thenIO_Prim` \ i1 ->
+ _casm_ ``((unsigned long *)%1)[0] = ((struct stat *)%0)->st_mtime;'' stat i1 `thenIO_Prim` \ () ->
+ cvtUnsigned i1 `thenIO_Prim` \ secs ->
+ return (TOD secs 0)
+ where
+ malloc1 = ST $ \ (S# s#) ->
+ case newIntArray# 1# s# of
+ StateAndMutableByteArray# s2# barr# -> (MutableByteArray bnds barr#, S# s2#)
+
+ bnds = (0,1)
+ -- The C routine fills in an unsigned word. We don't have `unsigned2Integer#,'
+ -- so we freeze the data bits and use them for an MP_INT structure. Note that
+ -- zero is still handled specially, although (J# 1# 1# (ptr to 0#)) is probably
+ -- acceptable to gmp.
+
+ cvtUnsigned (MutableByteArray _ arr#) = ST $ \ (S# s#) ->
+ case readIntArray# arr# 0# s# of
+ StateAndInt# s2# r# ->
+ if r# ==# 0# then
+ (0, S# s2#)
+ else
+ case unsafeFreezeByteArray# arr# s2# of
+ StateAndByteArray# s3# frozen# -> (J# 1# 1# frozen#, S# s3#)
+
+isDirectory :: FileStatus -> Bool
+isDirectory stat = unsafePerformPrimIO $
+ _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat >>= \ rc ->
+ return (rc /= 0)
+
+isRegularFile :: FileStatus -> Bool
+isRegularFile stat = unsafePerformPrimIO $
+ _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat >>= \ rc ->
+ return (rc /= 0)
+
+
+\end{code}
+
+\begin{code}
+type FileMode = Word
+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 stat = unsafePerformPrimIO $
+ _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat >>= \ mode ->
+ return mode
+
\end{code}
diff --git a/ghc/lib/required/IO.lhs b/ghc/lib/required/IO.lhs
index 34d5a338e660..c727c0082c09 100644
--- a/ghc/lib/required/IO.lhs
+++ b/ghc/lib/required/IO.lhs
@@ -39,7 +39,7 @@ import IOHandle -- much of the real stuff is in here
import PackedString ( nilPS, packCBytesST, unpackPS )
import PrelBase
import GHC
-import Foreign ( makeForeignObj )
+import Foreign ( makeForeignObj, writeForeignObj )
\end{code}
%*********************************************************
@@ -289,11 +289,14 @@ lazyReadBlock handle =
then return nilPS
else packCBytesST bytes buf) >>= \ some ->
if bytes < 0 then
- makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp ->
- ioToST (writeHandle handle (SemiClosedHandle null_fp (``NULL'', 0)))
- >>
_ccall_ free buf >>= \ () ->
_ccall_ closeFile fp >>
+#ifndef PAR
+ writeForeignObj fp ``NULL'' >>
+ ioToST (writeHandle handle (SemiClosedHandle fp (``NULL'', 0))) >>
+#else
+ ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))) >>
+#endif
returnPrimIO (unpackPS some)
else
ioToST (writeHandle handle htype) >>
@@ -314,11 +317,14 @@ lazyReadLine handle =
then return nilPS
else packCBytesST bytes buf) >>= \ some ->
if bytes < 0 then
- makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp ->
- ioToST (writeHandle handle (SemiClosedHandle null_fp (``NULL'', 0)))
- >>
_ccall_ free buf >>= \ () ->
_ccall_ closeFile fp >>
+#ifndef PAR
+ writeForeignObj fp ``NULL'' >>
+ ioToST (writeHandle handle (SemiClosedHandle fp (``NULL'', 0))) >>
+#else
+ ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))) >>
+#endif
returnPrimIO (unpackPS some)
else
ioToST (writeHandle handle htype) >>
@@ -336,10 +342,13 @@ lazyReadChar handle =
SemiClosedHandle fp buf_info ->
_ccall_ readChar fp >>= \ char ->
if char == ``EOF'' then
- makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp ->
- ioToST (writeHandle handle (SemiClosedHandle null_fp buf_info))
- >>
_ccall_ closeFile fp >>
+#ifndef PAR
+ writeForeignObj fp ``NULL'' >>
+ ioToST (writeHandle handle (SemiClosedHandle fp (``NULL'', 0))) >>
+#else
+ ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))) >>
+#endif
returnPrimIO ""
else
ioToST (writeHandle handle htype) >>
@@ -425,10 +434,18 @@ hPutStr handle str =
else
constructErrorAndFail "hPutStr"
where
+#ifndef PAR
writeLines :: ForeignObj -> String -> PrimIO Bool
+#else
+ writeLines :: Addr -> String -> PrimIO Bool
+#endif
writeLines = writeChunks ``BUFSIZ'' True
+#ifndef PAR
writeBlocks :: ForeignObj -> Int -> String -> PrimIO Bool
+#else
+ writeBlocks :: Addr -> Int -> String -> PrimIO Bool
+#endif
writeBlocks fp size s = writeChunks size False fp s
{-
@@ -443,8 +460,11 @@ hPutStr handle str =
a whole lot quicker. -- SOF 3/96
-}
+#ifndef PAR
writeChunks :: Int -> Bool -> ForeignObj -> String -> PrimIO Bool
-
+#else
+ writeChunks :: Int -> Bool -> Addr -> String -> PrimIO Bool
+#endif
writeChunks (I# bufLen) chopOnNewLine fp s =
newCharArray (0,I# bufLen) >>= \ arr@(MutableByteArray _ arr#) ->
let
@@ -478,7 +498,11 @@ hPutStr handle str =
in
shoveString 0# s
+#ifndef PAR
writeChars :: ForeignObj -> String -> PrimIO Bool
+#else
+ writeChars :: Addr -> String -> PrimIO Bool
+#endif
writeChars fp "" = returnPrimIO True
writeChars fp (c:cs) =
_ccall_ filePutc fp (ord c) >>= \ rc ->
diff --git a/ghc/lib/required/Time.lhs b/ghc/lib/required/Time.lhs
index 881166d8c9be..0c172e9ee13b 100644
--- a/ghc/lib/required/Time.lhs
+++ b/ghc/lib/required/Time.lhs
@@ -9,6 +9,8 @@ clock times, including timezone information (i.e, the functionality of
its use of Coordinated Universal Time (UTC).
\begin{code}
+{-# OPTIONS -#include "cbits/timezone.h" -#include "cbits/stgio.h" #-}
+
module Time
(
CalendarTime(..),
@@ -16,20 +18,23 @@ module Time
Day,
CalendarTime(CalendarTime),
TimeDiff(TimeDiff),
- ClockTime,
+ ClockTime(..), -- non-standard, lib. report gives this as abstract
getClockTime, addToClockTime, diffClockTimes,
toCalendarTime, toUTCTime, toClockTime,
- calendarToTimeString, formatCalendarTime
+ calendarTimeToString, formatCalendarTime
) where
import PrelBase
import ST
-import IOBase ( IOError(..), constructErrorAndFail )
+import IOBase
import ArrBase
import STBase
-
+import ST
+import Ix
+import Char (intToDigit)
import PackedString (unpackPS, packCBytesST)
-import PosixUtil (allocWords, allocChars)
+import Locale
+
\end{code}
One way to partition and give name to chunks of a year and a week:
@@ -53,8 +58,7 @@ Clock times may be compared, converted to strings, or converted to an
external calendar time @CalendarTime@.
\begin{code}
-data ClockTime = TOD Integer Integer
- deriving (Eq, Ord)
+data ClockTime = TOD Integer Integer deriving (Eq, Ord)
\end{code}
When a @ClockTime@ is shown, it is converted to a string of the form
@@ -244,7 +248,7 @@ toCalendarTime (TOD sec@(J# a# s# d#) psec) = unsafePerformPrimIO $
_ccall_ strlen zone >>= \ len ->
packCBytesST len zone >>= \ tzname ->
returnPrimIO (CalendarTime (1900+year) mon mday hour min sec psec
- wday yday (unpackPS tzname) tz (isdst /= 0))
+ (toEnum wday) yday (unpackPS tzname) tz (isdst /= 0))
toUTCTime :: ClockTime -> CalendarTime
toUTCTime (TOD sec@(J# a# s# d#) psec) = unsafePerformPrimIO (
@@ -265,7 +269,7 @@ toUTCTime (TOD sec@(J# a# s# d#) psec) = unsafePerformPrimIO (
_casm_ ``%r = ((struct tm *)%0)->tm_wday;'' tm >>= \ wday ->
_casm_ ``%r = ((struct tm *)%0)->tm_yday;'' tm >>= \ yday ->
returnPrimIO (CalendarTime (1900+year) mon mday hour min sec psec
- wday yday "UTC" 0 False)
+ (toEnum wday) yday "UTC" 0 False)
)
toClockTime :: CalendarTime -> ClockTime
@@ -287,79 +291,93 @@ toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz is
bottom :: (Int,Int)
bottom = error "Time.bottom"
+
+
+-- (copied from PosixUtil, for now)
+-- Allocate a mutable array of characters with no indices.
+
+allocChars :: Int -> ST s (MutableByteArray s ())
+allocChars (I# size#) = ST $ \ (S# s#) ->
+ case newCharArray# size# s# of
+ StateAndMutableByteArray# s2# barr# -> (MutableByteArray bot barr#, S# s2#)
+ where
+ bot = error "Time.allocChars"
+
+-- Allocate a mutable array of words with no indices
+
+allocWords :: Int -> ST s (MutableByteArray s ())
+allocWords (I# size#) = ST $ \ (S# s#) ->
+ case newIntArray# size# s# of
+ StateAndMutableByteArray# s2# barr# -> (MutableByteArray bot barr#, S# s2#)
+ where
+ bot = error "Time.allocWords"
+
\end{code}
\begin{code}
-calendarTimeToString :: CalendarTime -> String
-calendarTimeToString = formatCalendarTime defaultTimeLocale "%c"
-
-formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String
-formatCalendarTime l
- fmt
- ct@(CalendarTime
- year mon
- day hour
- min sec
- sdec
- wday yday tzname _ _)
- = doFmt fmt
- where
- doFmt ('%':c:cs) = decode c ++ doFmt cs
- doFmt (c:cs) = c : doFmt cs
- doFmt "" = ""
-
- to12 h = let h' = h `mod` 12 in if h == 0 then 12 else h
-
- decode 'A' = fst (wdays l !! fromEnum wday)
- decode 'a' = snd (wdays l !! fromEnum wday)
- decode 'B' = fst (months l !! fromEnum mon)
- decode 'b' = snd (months l !! fromEnum mon)
- decode 'h' = snd (months l !! fromEnum mon)
- decode 'C' = show2 (year `quot` 100)
- decode 'c' = doFmt (dateTimeFmt l)
- decode 'D' = doFmt "%m/%d/%y"
- decode 'd' = show2 day
- decode 'e' = show2' day
- decode 'H' = show2 hour
- decode 'I' = show2 (to12 hour)
- decode 'j' = show3 yday
- decode 'k' = show2' hour
- decode 'l' = show2' (to12 hour)
- decode 'M' = show2 min
- decode 'm' = show2 (fromEnum mon+1)
- decode 'n' = "\n"
- decode 'p' = (if hour < 12 then fst else snd) (amPm l)
- decode 'R' = doFmt "%H:%M"
- decode 'r' = doFmt (time12Fmt l)
- decode 'T' = doFmt "%H:%M:%S"
- decode 't' = "\t"
- decode 'S' = show2 sec
- decode 's' = show2 sec -- Implementation-dependent, sez the lib doc..
- decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7)
- decode 'u' = show (let n = fromEnum wday in if n == 0 then 7 else n)
- decode 'V' =
- let (week, days) =
- (yday + 7 - if fromEnum wday > 0 then
- fromEnum wday - 1 else 6) `divMod` 7
- in
- show2 (if days >= 4
- then week+1
- else if week == 0 then 53 else week)
- decode 'W' =
- show2 ((yday + 7 - if fromEnum wday > 0 then
- fromEnum wday - 1 else 6) `div` 7)
- decode 'w' = show (fromEnum wday)
- decode 'X' = doFmt (timeFmt l)
- decode 'x' = doFmt (dateFmt l)
- decode 'Y' = show year
- decode 'y' = show2 (year `rem` 100)
- decode 'Z' = tzname
- decode '%' = "%"
- decode c = [c]
-
-show2, show2', show3 :: Int -> String
-show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)]
-show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x
-show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100)
-
+calendarTimeToString :: CalendarTime -> String
+calendarTimeToString = formatCalendarTime defaultTimeLocale "%c"
+
+formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String
+formatCalendarTime l fmt ct@(CalendarTime year mon day hour min sec sdec
+ wday yday tzname _ _) =
+ doFmt fmt
+ where doFmt ('%':c:cs) = decode c ++ doFmt cs
+ doFmt (c:cs) = c : doFmt cs
+ doFmt "" = ""
+ to12 h = let h' = h `mod` 12 in if h == 0 then 12 else h
+ decode 'A' = fst (wDays l !! fromEnum wday)
+ decode 'a' = snd (wDays l !! fromEnum wday)
+ decode 'B' = fst (months l !! fromEnum mon)
+ decode 'b' = snd (months l !! fromEnum mon)
+ decode 'h' = snd (months l !! fromEnum mon)
+ decode 'C' = show2 (year `quot` 100)
+ decode 'c' = doFmt (dateTimeFmt l)
+ decode 'D' = doFmt "%m/%d/%y"
+ decode 'd' = show2 day
+ decode 'e' = show2' day
+ decode 'H' = show2 hour
+ decode 'I' = show2 (to12 hour)
+ decode 'j' = show3 yday
+ decode 'k' = show2' hour
+ decode 'l' = show2' (to12 hour)
+ decode 'M' = show2 min
+ decode 'm' = show2 (fromEnum mon+1)
+ decode 'n' = "\n"
+ decode 'p' = (if hour < 12 then fst else snd) (amPm l)
+ decode 'R' = doFmt "%H:%M"
+ decode 'r' = doFmt (time12Fmt l)
+ decode 'T' = doFmt "%H:%M:%S"
+ decode 't' = "\t"
+ decode 'S' = show2 sec
+ decode 's' = show2 sec -- Implementation-dependent, sez the lib doc..
+ decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7)
+ decode 'u' = show (let n = fromEnum wday in
+ if n == 0 then 7 else n)
+ decode 'V' =
+ let (week, days) =
+ (yday + 7 - if fromEnum wday > 0 then
+ fromEnum wday - 1 else 6) `divMod` 7
+ in show2 (if days >= 4 then
+ week+1
+ else if week == 0 then 53 else week)
+
+ decode 'W' =
+ show2 ((yday + 7 - if fromEnum wday > 0 then
+ fromEnum wday - 1 else 6) `div` 7)
+ decode 'w' = show (fromEnum wday)
+ decode 'X' = doFmt (timeFmt l)
+ decode 'x' = doFmt (dateFmt l)
+ decode 'Y' = show year
+ decode 'y' = show2 (year `rem` 100)
+ decode 'Z' = tzname
+ decode '%' = "%"
+ decode c = [c]
+
+show2, show2', show3 :: Int -> String
+show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)]
+
+show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x
+
+show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100)
\end{code}
diff --git a/ghc/mk/boilerplate.mk b/ghc/mk/boilerplate.mk
index 96782a0a792c..08e36c90b85b 100644
--- a/ghc/mk/boilerplate.mk
+++ b/ghc/mk/boilerplate.mk
@@ -24,11 +24,9 @@ TOP:=$(GHC_TOP)
# -----------------------------------------------------------------
# Everything after this point
# augments or overrides previously set variables.
-# (these files are optional, so `make' won't fret if
-# cannot get to them).
# -----------------------------------------------------------------
--include $(TOP)/mk/paths.mk
--include $(TOP)/mk/opts.mk
+include $(TOP)/mk/paths.mk
+include $(TOP)/mk/opts.mk
include $(TOP)/mk/suffix.mk
diff --git a/ghc/mk/paths.mk b/ghc/mk/paths.mk
index d7b30e7ae55d..635956a0c1b5 100644
--- a/ghc/mk/paths.mk
+++ b/ghc/mk/paths.mk
@@ -10,9 +10,13 @@ HaskellCompilerType = $(WithGhcHcType)
# What ways to build the RTS+libs
WAYS=$(GhcLibWays)
+GCap=-optc-DGCap
+#GC2s=-optc-DGC2s
+#GC1s=-optc-DGC1s
MKDEPENDHSSRC = $(GHC_UTILS_DIR)/mkdependHS
UNLIT = $(GHC_UNLIT_DIR)/unlit
+GHC_UNLIT = $(GHC_UNLIT_DIR)/unlit
GHC_UNLIT_DIR = $(GHC_UTILS_DIR)/unlit
#-----------------------------------------------------------------------------
@@ -29,10 +33,10 @@ endif
# Ugen
ifdef UseInstalledUtils
-UGEN = ugen
+UGEN = ugen
else
UGEN = $(UGEN_DIR)/ugen
-UGENSRC = $(GHC_UTILS_DIR)/ugen
+UGEN_DIR = $(GHC_UTILS_DIR)/ugen
endif
#-----------------------------------------------------------------------------
diff --git a/ghc/runtime/Makefile b/ghc/runtime/Makefile
index ff991b00828e..b5713a485976 100644
--- a/ghc/runtime/Makefile
+++ b/ghc/runtime/Makefile
@@ -1,5 +1,5 @@
#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.4 1997/03/14 05:11:52 sof Exp $
+# $Id: Makefile,v 1.5 1997/03/17 20:34:59 simonpj Exp $
# This is the Makefile for the runtime-system stuff.
# This stuff is written in C (and cannot be written in Haskell).
@@ -159,9 +159,9 @@ LIBOBJS = $(patsubst %.lc,%.$(way_)o,$(SRCS_RTS_LC)) \
#
# dependencies
#
-SRC_HC_OPTS += -I$(GHC_INCLUDE_DIR) -O -optc-DIN_GHC_RTS=1 -I$(GHC_RUNTIME_DIR)/storage
+SRC_HC_OPTS += -I$(GHC_INCLUDE_DIR) $(GCap) $(GC2s) $(GC1s) -O -optc-DIN_GHC_RTS=1 -I$(GHC_RUNTIME_DIR)/storage
-SRC_MKDEPENDC_OPTS += $(GCap) $(GC2s) $(GC1s)
+SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR) $(GCap) $(GC2s) $(GC1s)
#-----------------------------------------------------------------------------
# file-specific options
diff --git a/ghc/runtime/prims/PrimMisc.lc b/ghc/runtime/prims/PrimMisc.lc
index 953ed15b1243..021e0aa73688 100644
--- a/ghc/runtime/prims/PrimMisc.lc
+++ b/ghc/runtime/prims/PrimMisc.lc
@@ -43,6 +43,8 @@ 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 */
}
diff --git a/mk/config.mk.in b/mk/config.mk.in
index c8fa245ed7f9..0cc939bbfebb 100644
--- a/mk/config.mk.in
+++ b/mk/config.mk.in
@@ -181,6 +181,11 @@ GhcLibHcOpts= -split-objs -odir $(basename $*)
# Build the Haskell Readline bindings?
#
HsLibsWithReadline=YES
+#
+# Include path to readline.h
+# (no path == in standard include path)
+#
+ReadlineIncludePath=
# Build the socket libraries?
#
@@ -192,6 +197,9 @@ HsLibsWithSockets=YES
#
HsLibWays=$(GhcLibWays)
+# Option flags for hslibs are by default the same as for the options
+# used for the prelude libs (see above).
+HsLibHcOpts=$(GhcLibHcOpts)
#################################################################################
#
@@ -265,37 +273,32 @@ NoFibHcOpts=
#
#################################################################################
-# These variables are all ":=" variables so that you can easily attach
-# extra stuff to the end of them, like this:
-#
-# libdir := $(libdir)/ghc
-
-TMPDIR := /tmp
+TMPDIR = /tmp
# FPTOOLS_TOP: the top of the fptools hierarchy, absolute path.
-FPTOOLS_TOP_ABS := @hardtop@
+FPTOOLS_TOP_ABS = @hardtop@
#
# Installation directories, we don't use half of these,
# but since the configure script has them on offer while
# passing through, we might as well set them.
-prefix := @prefix@
-exec_prefix := @exec_prefix@
-bindir := @bindir@
-sbindir := @sbindir@
-libexecdir := @libexecdir@
-datadir := @datadir@
-sysconfdir := @datadir@
-sharedstatedir := @sharedstatedir@
-localstatedir := @localstatedir@
-libdir := @libdir@
-infodir := @infodir@
-includedir := @includedir@
-oldincludedir := @oldincludedir@
-mandir := @mandir@
-srcdir := @srcdir@
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+bindir = @bindir@
+sbindir = @sbindir@
+libexecdir = @libexecdir@
+datadir = @datadir@
+sysconfdir = @datadir@
+sharedstatedir = @sharedstatedir@
+localstatedir = @localstatedir@
+libdir = @libdir@
+infodir = @infodir@
+includedir = @includedir@
+oldincludedir = @oldincludedir@
+mandir = @mandir@
+srcdir = @srcdir@
#################################################################################
#
diff --git a/mk/target.mk b/mk/target.mk
index 28b3d7ce7f23..d1d112949ec7 100644
--- a/mk/target.mk
+++ b/mk/target.mk
@@ -689,15 +689,16 @@ ifneq "$(filter -monolithic,$(TEXI2HTML_OPTS))" ""
$(LIT2TEXI) -S -c $(LIT2TEXI_OPTS) -o $(patsubst %.html,%.itxi,$@) $(addsuffix .lit,$(basename $@))
$(LIT2TEXI) -S $(LIT2TEXI_OPTS) -o $(patsubst %.html,%.texi,$@) $(addsuffix .itxi,$(basename $@))
$(TEXI2HTML) $(TEXI2HTML_OPTS) $(patsubst %.html,%.texi,$@)
+ cp $(TEXI2HTML_PREFIX)invisible.xbm .
else
$(RM) html/$(basename $@)*
$(MKDIRHIER) html
$(LIT2TEXI) -S -c $(LIT2TEXI_OPTS) -o $(patsubst %.html,%.itxi,$@) $(addsuffix .lit,$(basename $@))
$(LIT2TEXI) -S $(LIT2TEXI_OPTS) -o html/$(patsubst %.html,%.texi,$@) $(addsuffix .itxi,$(basename $@))
(cd html; ../$(TEXI2HTML) $(TEXI2HTML_OPTS) $(patsubst %.html,%.texi,$@); cd ..)
+ cp $(TEXI2HTML_PREFIX)invisible.xbm html/
@touch $@
endif
-
###########################################
#
# Targets: clean
--
GitLab