Commit 2494407a authored by simonpj's avatar simonpj
Browse files

[project @ 1997-03-17 20:34:25 by simonpj]

More small changes towards 2.02
parent 1fb1ab5d
......@@ -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
@:
TOP = ..
include $(TOP)/mk/boilerplate.mk
DOC_SRCS = installing.lit release.lit
DOC_SRCS = installing.lit
SRC_TEXI2HTML_OPTS += -number -monolithic -invisible xbm
......
......@@ -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}
......
#-----------------------------------------------------------------------------
# $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.
......
# -----------------------------------------------------------------------------
# $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
......
......@@ -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 ])
......
......@@ -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}
......@@ -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
......
......@@ -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"))
......
......@@ -155,6 +155,7 @@ data PrimOp
| ReadIVarOp | WriteIVarOp
| 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
......@@ -1558,6 +1591,7 @@ 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
......@@ -1629,6 +1663,7 @@ primOpNeedsWrapper DoubleEncodeOp = True
primOpNeedsWrapper DoubleDecodeOp = True
primOpNeedsWrapper MakeForeignObjOp = True
primOpNeedsWrapper WriteForeignObjOp = True
primOpNeedsWrapper MakeStablePtrOp = True
primOpNeedsWrapper DeRefStablePtrOp = True
......
......@@ -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
......
......@@ -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
= 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
-- 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
......
......@@ -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
......
......@@ -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,8 +1340,7 @@ specPrimOp :: PrimOp
specExpr (App fun arg) args
= -- If TyArg, arg will be processed; otherwise, left alone
specArg arg `thenSM` \ new_arg ->
= specArg arg `thenSM` \ new_arg ->
specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
returnSM (expr, uds)
......@@ -1564,14 +1549,14 @@ 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
......@@ -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
= returnSM emptyUDs
-- No call instances for SuperDictSelIds
-- These are a special case in mkCall
| maybeToBool (isSuperDictSelId_maybe 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
-- 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
= returnSM (singleCI new_id spec_tys dicts)
where
(tyvars, class_tyvar_pairs) = getIdOverloading id
constrained_tyvars = map snd class_tyvar_pairs -- May contain dups