diff options
| author | simonpj <unknown> | 2000-03-23 17:45:33 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 2000-03-23 17:45:33 +0000 |
| commit | 111cee3f1ad93816cb828e38b38521d85c3bcebb (patch) | |
| tree | 65f0517386e1855a8bd7198eff92b2e12b07b923 | |
| parent | 290e7896a6785ba5dcfbc7045438f382afd447ff (diff) | |
| download | haskell-111cee3f1ad93816cb828e38b38521d85c3bcebb.tar.gz | |
[project @ 2000-03-23 17:45:17 by simonpj]
This utterly gigantic commit is what I've been up to in background
mode in the last couple of months. Originally the main goal
was to get rid of Con (staturated constant applications)
in the CoreExpr type, but one thing led to another, and I kept
postponing actually committing. Sorry.
Simon, 23 March 2000
I've tested it pretty thoroughly, but doubtless things will break.
Here are the highlights
* Con is gone; the CoreExpr type is simpler
* NoRepLits have gone
* Better usage info in interface files => less recompilation
* Result type signatures work
* CCall primop is tidied up
* Constant folding now done by Rules
* Lots of hackery in the simplifier
* Improvements in CPR and strictness analysis
Many bug fixes including
* Sergey's DoCon compiles OK; no loop in the strictness analyser
* Volker Wysk's programs don't crash the CPR analyser
I have not done much on measuring compilation times and binary sizes;
they could have got worse. I think performance has got significantly
better, though, in most cases.
Removing the Con form of Core expressions
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The big thing is that
For every constructor C there are now *two* Ids:
C is the constructor's *wrapper*. It evaluates and unboxes arguments
before calling $wC. It has a perfectly ordinary top-level defn
in the module defining the data type.
$wC is the constructor's *worker*. It is like a primop that simply
allocates and builds the constructor value. Its arguments are the
actual representation arguments of the constructor.
Its type may be different to C, because:
- useless dict args are dropped
- strict args may be flattened
For every primop P there is *one* Id, its (curried) Id
Neither contructor worker Id nor the primop Id have a defminition anywhere.
Instead they are saturated during the core-to-STG pass, and the code generator
generates code for them directly. The STG language still has saturated
primops and constructor applications.
* The Const type disappears, along with Const.lhs. The literal part
of Const.lhs reappears as Literal.lhs. Much tidying up in here,
to bring all the range checking into this one module.
* I got rid of NoRep literals entirely. They just seem to be too much trouble.
* Because Con's don't exist any more, the funny C { args } syntax
disappears from inteface files.
Parsing
~~~~~~~
* Result type signatures now work
f :: Int -> Int = \x -> x
-- The Int->Int is the type of f
g x y :: Int = x+y
-- The Int is the type of the result of (g x y)
Recompilation checking and make
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* The .hi file for a modules is not touched if it doesn't change. (It used to
be touched regardless, forcing a chain of recompilations.) The penalty for this
is that we record exported things just as if they were mentioned in the body of
the module. And the penalty for that is that we may recompile a module when
the only things that have changed are the things it is passing on without using.
But it seems like a good trade.
* -recomp is on by default
Foreign declarations
~~~~~~~~~~~~~~~~~~~~
* If you say
foreign export zoo :: Int -> IO Int
then you get a C produre called 'zoo', not 'zzoo' as before.
I've also added a check that complains if you export (or import) a C
procedure whose name isn't legal C.
Code generation and labels
~~~~~~~~~~~~~~~~~~~~~~~~~~
* Now that constructor workers and wrappers have distinct names, there's
no need to have a Foo_static_closure and a Foo_closure for constructor Foo.
I nuked the entire StaticClosure story. This has effects in some of
the RTS headers (i.e. s/static_closure/closure/g)
Rules, constant folding
~~~~~~~~~~~~~~~~~~~~~~~
* Constant folding becomes just another rewrite rule, attached to the Id for the
PrimOp. To achieve this, there's a new form of Rule, a BuiltinRule (see CoreSyn.lhs).
The prelude rules are in prelude/PrelRules.lhs, while simplCore/ConFold.lhs has gone.
* Appending of constant strings now works, using fold/build fusion, plus
the rewrite rule
unpack "foo" c (unpack "baz" c n) = unpack "foobaz" c n
Implemented in PrelRules.lhs
* The CCall primop is tidied up quite a bit. There is now a data type CCall,
defined in PrimOp, that packages up the info needed for a particular CCall.
There is a new Id for each new ccall, with an big "occurrence name"
{__ccall "foo" gc Int# -> Int#}
In interface files, this is parsed as a single Id, which is what it is, really.
Miscellaneous
~~~~~~~~~~~~~
* There were numerous places where the host compiler's
minInt/maxInt was being used as the target machine's minInt/maxInt.
I nuked all of these; everything is localised to inIntRange and inWordRange,
in Literal.lhs
* Desugaring record updates was broken: it didn't generate correct matches when
used withe records with fancy unboxing etc. It now uses matchWrapper.
* Significant tidying up in codeGen/SMRep.lhs
* Add __word, __word64, __int64 terminals to signal the obvious types
in interface files. Add the ability to print word values in hex into
C code.
* PrimOp.lhs is no longer part of a loop. Remove PrimOp.hi-boot*
Types
~~~~~
* isProductTyCon no longer returns False for recursive products, nor
for unboxed products; you have to test for these separately.
There's no reason not to do CPR for recursive product types, for example.
Ditto splitProductType_maybe.
Simplification
~~~~~~~~~~~~~~~
* New -fno-case-of-case flag for the simplifier. We use this in the first run
of the simplifier, where it helps to stop messing up expressions that
the (subsequent) full laziness pass would otherwise find float out.
It's much more effective than previous half-baked hacks in inlining.
Actually, it turned out that there were three places in Simplify.lhs that
needed to know use this flag.
* Make the float-in pass push duplicatable bindings into the branches of
a case expression, in the hope that we never have to allocate them.
(see FloatIn.sepBindsByDropPoint)
* Arrange that top-level bottoming Ids get a NOINLINE pragma
This reduced gratuitous inlining of error messages.
But arrange that such things still get w/w'd.
* Arrange that a strict argument position is regarded as an 'interesting'
context, so that if we see
foldr k z (g x)
then we'll be inclined to inline g; this can expose a build.
* There was a missing case in CoreUtils.exprEtaExpandArity that meant
we were missing some obvious cases for eta expansion
Also improve the code when handling applications.
* Make record selectors (identifiable by their IdFlavour) into "cheap" operations.
[The change is a 2-liner in CoreUtils.exprIsCheap]
This means that record selection may be inlined into function bodies, which
greatly improves the arities of overloaded functions.
* Make a cleaner job of inlining "lone variables". There was some distributed
cunning, but I've centralised it all now in SimplUtils.analyseCont, which
analyses the context of a call to decide whether it is "interesting".
* Don't specialise very small functions in Specialise.specDefn
It's better to inline it. Rather like the worker/wrapper case.
* Be just a little more aggressive when floating out of let rhss.
See comments with Simplify.wantToExpose
A small change with an occasional big effect.
* Make the inline-size computation think that
case x of I# x -> ...
is *free*.
CPR analysis
~~~~~~~~~~~~
* Fix what was essentially a bug in CPR analysis. Consider
letrec f x = let g y = let ... in f e1
in
if ... then (a,b) else g x
g has the CPR property if f does; so when generating the final annotated
RHS for f, we must use an envt in which f is bound to its final abstract
value. This wasn't happening. Instead, f was given the CPR tag but g
wasn't; but of course the w/w pass gives rotten results in that case!!
(Because f's CPR-ness relied on g's.)
On they way I tidied up the code in CprAnalyse. It's quite a bit shorter.
The fact that some data constructors return a constructed product shows
up in their CPR info (MkId.mkDataConId) not in CprAnalyse.lhs
Strictness analysis and worker/wrapper
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* BIG THING: pass in the demand to StrictAnal.saExpr. This affects situations
like
f (let x = e1 in (x,x))
where f turns out to have strictness u(SS), say. In this case we can
mark x as demanded, and use a case expression for it.
The situation before is that we didn't "know" that there is the u(SS)
demand on the argument, so we simply computed that the body of the let
expression is lazy in x, and marked x as lazily-demanded. Then even after
f was w/w'd we got
let x = e1 in case (x,x) of (a,b) -> $wf a b
and hence
let x = e1 in $wf a b
I found a much more complicated situation in spectral/sphere/Main.shade,
which improved quite a bit with this change.
* Moved the StrictnessInfo type from IdInfo to Demand. It's the logical
place for it, and helps avoid module loops
* Do worker/wrapper for coerces even if the arity is zero. Thus:
stdout = coerce Handle (..blurg..)
==>
wibble = (...blurg...)
stdout = coerce Handle wibble
This is good because I found places where we were saying
case coerce t stdout of { MVar a ->
...
case coerce t stdout of { MVar b ->
...
and the redundant case wasn't getting eliminated because of the coerce.
177 files changed, 5315 insertions, 5968 deletions
diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES index 34931bd9c9..859d1a2142 100644 --- a/ghc/compiler/DEPEND-NOTES +++ b/ghc/compiler/DEPEND-NOTES @@ -18,20 +18,27 @@ then then Type (loop DataCon.DataCon, loop Subst.substTy) then - DataCon, TysPrim, Unify, PprType + TysPrim (Type), PprEnv (loop DataCon.DataCon, Type) +then + Unify, PprType (PprEnv) +then + Literal (TysPrim, PprType), DataCon then InstEnv (Unify) then - IdInfo (loop CoreRules.CoreRules) TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId) then - PrimOp (PprType, TysWiredIn, IdInfo.StrictnessInfo) + PrimOp (PprType, TysWiredIn) +then + IdInfo (loop CoreSyn.CoreRules, loop CoreUnfold.Unfolding) then Const (PrimOp.PrimOp, TysWiredIn.stringTy) then Id (Const.Con(..)), CoreSyn then - CoreUtils (loop PprCore.pprCoreExpr), CoreFVs + CoreFVs, PprCore +then + CoreUtils (PprCore.pprCoreExpr, CoreFVs.exprFreeVars) then OccurAnal (ThinAir.noRepStrs -- an awkward dependency) then diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index c4f6d2eb42..20df8aae59 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.71 2000/02/14 11:59:27 sewardj Exp $ +# $Id: Makefile,v 1.72 2000/03/23 17:45:17 simonpj Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -44,6 +44,10 @@ ifeq ($(GhcWithNativeCodeGen),YES) DIRS += nativeGen else SRC_HC_OPTS += -DOMIT_NATIVE_CODEGEN +ifeq ($(GhcWithIlx),YES) +DIRS += ilxGen +SRC_HC_OPTS += -DILX +endif endif diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 74da4a3fdc..3cf44fa3f3 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: AbsCSyn.lhs,v 1.28 2000/03/16 12:37:06 simonmar Exp $ +% $Id: AbsCSyn.lhs,v 1.29 2000/03/23 17:45:17 simonpj Exp $ % \section[AbstractC]{Abstract C: the last stop before machine code} @@ -39,17 +39,13 @@ module AbsCSyn {- ( import {-# SOURCE #-} ClosureInfo ( ClosureInfo ) -#if ! OMIT_NATIVE_CODEGEN -import {-# SOURCE #-} MachMisc -#endif - import CLabel import Constants ( mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG, spRelToInt ) import CostCentre ( CostCentre, CostCentreStack ) -import Const ( mkMachInt, Literal(..) ) +import Literal ( mkMachInt, Literal(..) ) import PrimRep ( PrimRep(..) ) -import PrimOp ( PrimOp ) +import PrimOp ( PrimOp, CCall ) import Unique ( Unique ) import StgSyn ( SRT(..) ) import TyCon ( TyCon ) @@ -167,7 +163,7 @@ stored in a mixed type location.) compiling 'foreign import dynamic's) -} | CCallTypedef Bool {- True => use "typedef"; False => use "extern"-} - PrimOp{-CCallOp-} [CAddrMode] [CAddrMode] + CCall [CAddrMode] [CAddrMode] -- *** the next three [or so...] are DATA (those above are CODE) *** diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 18ef770a39..188dde5721 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -22,14 +22,14 @@ module AbsCUtils ( import AbsCSyn import Digraph ( stronglyConnComp, SCC(..) ) import DataCon ( fIRST_TAG, ConTag ) -import Const ( literalPrimRep, mkMachWord ) +import Literal ( literalPrimRep, mkMachWord ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import Unique ( Unique{-instance Eq-} ) import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, UniqSupply ) import CmdLineOpts ( opt_ProduceC, opt_EmitCExternDecls ) import Maybes ( maybeToBool ) -import PrimOp ( PrimOp(..) ) +import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import Panic ( panic ) infixr 9 `thenFlt` @@ -329,17 +329,16 @@ flatAbsC (CSwitch discrim alts deflt) = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) -> returnFlt ( (tag, alt_heres), alt_tops ) -flatAbsC stmt@(COpStmt results td@(CCallOp _ _ _ _) args vol_regs) +flatAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) | isCandidate && maybeToBool opt_ProduceC = returnFlt (stmt, tdef) where (isCandidate, isDyn) = - case td of - CCallOp (Right _) _ _ _ -> (True, True) - CCallOp (Left _) is_asm _ _ -> (opt_EmitCExternDecls && not is_asm, False) - _ -> (False, False) + case ccall of + CCall (DynamicTarget _) _ _ _ -> (True, True) + CCall (StaticTarget _) is_asm _ _ -> (opt_EmitCExternDecls && not is_asm, False) - tdef = CCallTypedef isDyn td results args + tdef = CCallTypedef isDyn ccall results args flatAbsC stmt@(CSimultaneous abs_c) = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) -> diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 546c060c55..4215354850 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CLabel.lhs,v 1.31 2000/03/16 12:37:06 simonmar Exp $ +% $Id: CLabel.lhs,v 1.32 2000/03/23 17:45:17 simonpj Exp $ % \section[CLabel]{@CLabel@: Information to make C Labels} @@ -18,7 +18,6 @@ module CLabel ( mkStaticConEntryLabel, mkRednCountsLabel, mkConInfoTableLabel, - mkStaticClosureLabel, mkStaticInfoTableLabel, mkApEntryLabel, mkApInfoTableLabel, @@ -143,9 +142,6 @@ data IdLabelInfo data DataConLabelInfo = ConEntry -- the only kind of entry pt for constructors | ConInfoTbl -- corresponding info table - - | StaticClosure -- Static constructor closure - -- e.g., nullary constructor | StaticConEntry -- static constructor entry point | StaticInfoTbl -- corresponding info table deriving (Eq, Ord) @@ -201,7 +197,6 @@ mkFastEntryLabel id arity = ASSERT(arity > 0) mkRednCountsLabel id = IdLabel id RednCounts -mkStaticClosureLabel con = DataConLabel con StaticClosure mkStaticInfoTableLabel con = DataConLabel con StaticInfoTbl mkConInfoTableLabel con = DataConLabel con ConInfoTbl mkConEntryLabel con = DataConLabel con ConEntry @@ -328,7 +323,6 @@ labelType (DataConLabel _ info) = case info of ConInfoTbl -> InfoTblType StaticInfoTbl -> InfoTblType - StaticClosure -> ClosureType _ -> CodeType labelType _ = DataType @@ -379,7 +373,6 @@ internal names. <type> is one of the following: dflt Default case alternative btm Large bitmap vector closure Static closure - static_closure Static closure (???) con_entry Dynamic Constructor entry code con_info Dynamic Constructor info table static_entry Static Constructor entry code @@ -492,7 +485,6 @@ ppIdFlavor x = pp_cSEP <> ppConFlavor x = pp_cSEP <> (case x of - StaticClosure -> ptext SLIT("static_closure") ConEntry -> ptext SLIT("con_entry") ConInfoTbl -> ptext SLIT("con_info") StaticConEntry -> ptext SLIT("static_entry") diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs index dcbf165aa1..628b540568 100644 --- a/ghc/compiler/absCSyn/CStrings.lhs +++ b/ghc/compiler/absCSyn/CStrings.lhs @@ -2,6 +2,7 @@ This module deals with printing C string literals \begin{code} module CStrings( + CLabelString, isCLabelString, cSEP, pp_cSEP, stringToC, charToC, pprFSInCStyle, @@ -10,23 +11,33 @@ module CStrings( #include "HsVersions.h" -import Char ( ord, chr ) +import Char ( ord, chr, isAlphaNum ) import Outputable \end{code} \begin{code} +type CLabelString = FAST_STRING -- A C label, completely unencoded + +isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label +isCLabelString lbl + = all ok (_UNPK_ lbl) + where + ok c = isAlphaNum c || c == '_' || c == '.' + -- The '.' appears in e.g. "foo.so" in the + -- module part of a ExtName. Maybe it should be separate + cSEP = SLIT("_") -- official C separator pp_cSEP = char '_' +\end{code} -stringToC :: String -> String -charToC, charToEasyHaskell :: Char -> String - +\begin{code} pprFSInCStyle :: FAST_STRING -> SDoc pprFSInCStyle fs = doubleQuotes (text (stringToC (_UNPK_ fs))) --- stringToC: the hassle is what to do w/ strings like "ESC 0"... - +stringToC :: String -> String +-- Convert a string to the form required by C in a C literal string +-- Tthe hassle is what to do w/ strings like "ESC 0"... stringToC "" = "" stringToC [c] = charToC c stringToC (c:cs) @@ -45,6 +56,8 @@ stringToC (c:cs) | c == '\v' = "\\v" | otherwise = '\\' : (octify (ord c)) +charToC :: Char -> String +-- Convert a character to the form reqd in a C character literal charToC c = if (c >= ' ' && c <= '~') -- non-portable... then case c of '\'' -> "\\'" @@ -60,8 +73,8 @@ charToC c = if (c >= ' ' && c <= '~') -- non-portable... _ -> [c] else '\\' : (octify (ord c)) --- really: charToSimpleHaskell - +charToEasyHaskell :: Char -> String +-- Convert a character to the form reqd in a Haskell character literal charToEasyHaskell c = if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index 7bbadff4f1..f3aee7832f 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: Costs.lhs,v 1.20 2000/01/13 14:33:57 hwloidl Exp $ +% $Id: Costs.lhs,v 1.21 2000/03/23 17:45:17 simonpj Exp $ % % Only needed in a GranSim setup -- HWL % --------------------------------------------------------------------------- @@ -390,7 +390,7 @@ primOpCosts :: PrimOp -> CostRes -- Special cases -primOpCosts (CCallOp _ _ _ _) = SAVE_COSTS + RESTORE_COSTS +primOpCosts (CCallOp _) = SAVE_COSTS + RESTORE_COSTS -- don't guess costs of ccall proper -- for exact costing use a GRAN_EXEC -- in the C code @@ -455,124 +455,3 @@ costsByKind DoubleRep _ = nullCosts -} -- --------------------------------------------------------------------------- \end{code} - -This is the data structure of {\tt PrimOp} copied from prelude/PrimOp.lhs. -I include here some comments about the estimated costs for these @PrimOps@. -Compare with the @primOpCosts@ fct above. -- HWL - -\begin{pseudocode} -data PrimOp - -- I assume all these basic comparisons take just one ALU instruction - -- Checked that for Char, Int; Word, Addr should be the same as Int. - - = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp - | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp - | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp - | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp - - -- Analogously, these take one FP unit instruction - -- Haven't checked that, yet. - - | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp - | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp - - -- 1 ALU op; unchecked - | OrdOp | ChrOp - - -- these just take 1 ALU op; checked - | IntAddOp | IntSubOp - - -- but these take more than that; see special cases in primOpCosts - -- I counted the generated ass. instructions for these -> checked - | IntMulOp | IntQuotOp - | IntRemOp | IntNegOp - - -- Rest is unchecked so far -- HWL - - -- Word#-related ops: - | AndOp | OrOp | NotOp | XorOp | ShiftLOp | ShiftROp - | Int2WordOp | Word2IntOp -- casts - - -- Addr#-related ops: - | Int2AddrOp | Addr2IntOp -- casts - - -- Float#-related ops: - | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp - | Float2IntOp | Int2FloatOp - - | FloatExpOp | FloatLogOp | FloatSqrtOp - | FloatSinOp | FloatCosOp | FloatTanOp - | FloatAsinOp | FloatAcosOp | FloatAtanOp - | FloatSinhOp | FloatCoshOp | FloatTanhOp - -- not all machines have these available conveniently: - -- | FloatAsinhOp | FloatAcoshOp | FloatAtanhOp - | FloatPowerOp -- ** op - - -- Double#-related ops: - | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp - | Double2IntOp | Int2DoubleOp - | Double2FloatOp | Float2DoubleOp - - | DoubleExpOp | DoubleLogOp | DoubleSqrtOp - | DoubleSinOp | DoubleCosOp | DoubleTanOp - | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp - | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp - -- not all machines have these available conveniently: - -- | DoubleAsinhOp | DoubleAcoshOp | DoubleAtanhOp - | DoublePowerOp -- ** op - - -- Integer (and related...) ops: - -- slightly weird -- to match GMP package. - | IntegerAddOp | IntegerSubOp | IntegerMulOp - | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp - - | IntegerCmpOp - - | Integer2IntOp | Int2IntegerOp - | Addr2IntegerOp -- "Addr" is *always* a literal string - -- ?? gcd, etc? - - | FloatEncodeOp | FloatDecodeOp - | DoubleEncodeOp | DoubleDecodeOp - - -- primitive ops for primitive arrays - - | NewArrayOp - | NewByteArrayOp PrimRep - - | SameMutableArrayOp - | SameMutableByteArrayOp - - | ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs - - | ReadByteArrayOp PrimRep - | WriteByteArrayOp PrimRep - | IndexByteArrayOp PrimRep - | IndexOffAddrOp PrimRep - -- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind. - -- This is just a cheesy encoding of a bunch of ops. - -- Note that ForeignObjRep is not included -- the only way of - -- creating a ForeignObj is with a ccall or casm. - - | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp - - | MakeStablePtrOp | DeRefStablePtrOp -\end{pseudocode} - -A special ``trap-door'' to use in making calls direct to C functions: -Note: From GrAn point of view, CCall is probably very expensive - The programmer can specify the costs of the Ccall by inserting - a GRAN_EXEC(a,b,l,s,f) at the end of the C- code, specifing the - number or arithm., branch, load, store and floating point instructions - -- HWL - -\begin{pseudocode} - | CCallOp String -- An "unboxed" ccall# to this named function - Bool -- True <=> really a "casm" - Bool -- True <=> might invoke Haskell GC - [Type] -- Unboxed argument; the state-token - -- argument will have been put *first* - Type -- Return type; one of the "StateAnd<blah>#" types - - -- (... to be continued ... ) -\end{pseudocode} diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index ff1e5c3597..4c147c4a1e 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -26,11 +26,11 @@ import AbsCUtils ( getAmodeRep, nonemptyAbsC, ) import Constants ( mIN_UPD_SIZE ) -import CallConv ( CallConv, callConvAttribute, cCallConv ) +import CallConv ( CallConv, callConvAttribute ) import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel, needsCDecl, pprCLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, - mkStaticClosureLabel, + mkClosureLabel, CLabel, CLabelType(..), labelType, labelDynamic ) @@ -40,12 +40,12 @@ import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl ) import Costs ( costs, addrModeCosts, CostRes(..), Side(..) ) import CStrings ( stringToC ) import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap ) -import Const ( Literal(..) ) +import Literal ( Literal(..) ) import TyCon ( tyConDataCons ) import Name ( NamedThing(..) ) -import DataCon ( DataCon{-instance NamedThing-} ) +import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId ) import Maybes ( maybeToBool, catMaybes ) -import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) ) +import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..), CCall(..), CCallTarget(..) ) import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep ) import SMRep ( pprSMRep ) import Unique ( pprUnique, Unique{-instance NamedThing-} ) @@ -176,8 +176,8 @@ pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt do_if_stmt discrim tag alt_code dc c -- What problem is the re-ordering trying to solve ? -pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1), - (tag2@(MachInt i2 _), alt_code2)] deflt) c +pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1), + (tag2@(MachInt i2), alt_code2)] deflt) c | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0)) = if (i1 == 0) then do_if_stmt discrim tag1 alt_code1 alt_code2 c @@ -213,8 +213,8 @@ pprAbsC (CSwitch discrim alts deflt) c -- general case -- Costs for addressing header of switch and cond. branching -- HWL switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0)) -pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _) args vol_regs) _ - = pprCCall op args results vol_regs +pprAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) _ + = pprCCall ccall args results vol_regs pprAbsC stmt@(COpStmt results op args vol_regs) _ = let @@ -284,7 +284,7 @@ pprAbsC (CCallProfCtrMacro op as) _ pprAbsC (CCallProfCCMacro op as) _ = hcat [ptext op, lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -pprAbsC stmt@(CCallTypedef is_tdef op@(CCallOp op_str is_asm may_gc cconv) results args) _ +pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results args) _ = hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern")) , ccall_res_ty , fun_nm @@ -327,8 +327,8 @@ pprAbsC stmt@(CCallTypedef is_tdef op@(CCallOp op_str is_asm may_gc cconv) resul ccall_fun_ty = case op_str of - Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u - Left x -> ptext x + DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u + StaticTarget x -> ptext x ccall_res_ty = case non_void_results of @@ -505,7 +505,7 @@ pprAbsC stmt@(CClosureTbl tycon) _ ptext SLIT("CLOSURE_TBL") <> lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen : punctuate comma ( - map (pp_closure_lbl . mkStaticClosureLabel . getName) (tyConDataCons tycon) + map (pp_closure_lbl . mkClosureLabel . getName . dataConWrapId) (tyConDataCons tycon) ) ) $$ ptext SLIT("};") @@ -637,18 +637,13 @@ ppr_vol_regs (r:rs) (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves, ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores) --- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and +-- pp_basic_{saves,restores}: The BaseReg, Sp, Su, Hp and -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls, -- depending on the platform. (The "volatile regs" stuff handles all -- other registers.) Just be *sure* BaseReg is OK before trying to do -- anything else. The correct sequence of saves&restores are -- encoded by the CALLER_*_SYSTEM macros. -pp_basic_saves - = vcat - [ ptext SLIT("CALLER_SAVE_Base") - , ptext SLIT("CALLER_SAVE_SYSTEM") - ] - +pp_basic_saves = ptext SLIT("CALLER_SAVE_SYSTEM") pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM") \end{code} @@ -690,10 +685,10 @@ do_if_stmt discrim tag alt_code deflt c = case tag of -- This special case happens when testing the result of a comparison. -- We can just avoid some redundant clutter in the output. - MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim) + MachInt n | n==0 -> ppr_if_stmt (pprAmode discrim) deflt alt_code (addrModeCosts discrim Rhs) c - other -> let + other -> let cond = hcat [ pprAmode discrim , ptext SLIT(" == ") , tcast @@ -707,10 +702,9 @@ do_if_stmt discrim tag alt_code deflt c -- in C (when minInt is a number not a constant -- expression which evaluates to it.) -- - tcast = - case other of - MachInt _ signed | signed -> ptext SLIT("(I_)") - _ -> empty + tcast = case other of + MachInt _ -> ptext SLIT("(I_)") + _ -> empty in ppr_if_stmt cond alt_code deflt @@ -783,7 +777,7 @@ Amendment to the above: if we can GC, we have to: that the runtime check that PerformGC is being used sensibly will work. \begin{code} -pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs +pprCCall (CCall op_str is_asm may_gc cconv) args results vol_regs = vcat [ char '{', declare_local_vars, -- local var for *result* @@ -829,17 +823,17 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs ccall_fun_ty = ptext SLIT("_ccall_fun_ty") <> case op_str of - Right u -> ppr u - _ -> empty + DynamicTarget u -> ppr u + _ -> empty (declare_local_vars, local_vars, assign_results) = ppr_casm_results non_void_results - (Left asm_str) = op_str + (StaticTarget asm_str) = op_str is_dynamic = case op_str of - Left _ -> False - _ -> True + StaticTarget _ -> False + DynamicTarget _ -> True casm_str = if is_asm then _UNPK_ asm_str else ccall_str @@ -1201,9 +1195,9 @@ pp_liveness :: Liveness -> SDoc pp_liveness lv = case lv of LvLarge lbl -> char '&' <> pprCLabel lbl - LvSmall mask - | bitmap_int == (minBound :: Int) -> int (bitmap_int+1) <> text "-1" - | otherwise -> int bitmap_int + LvSmall mask -- Avoid gcc bug when printing minInt + | bitmap_int == minInt -> int (bitmap_int+1) <> text "-1" + | otherwise -> int bitmap_int where bitmap_int = intBS mask \end{code} @@ -1621,7 +1615,7 @@ floatToWord (CLit (MachFloat r)) arr <- newFloatArray ((0::Int),0) writeFloatArray arr 0 (fromRational r) i <- readIntArray arr 0 - return (CLit (MachInt (toInteger i) True)) + return (CLit (MachInt (toInteger i))) ) doubleToWords :: CAddrMode -> [CAddrMode] @@ -1632,8 +1626,8 @@ doubleToWords (CLit (MachDouble r)) writeDoubleArray arr 0 (fromRational r) i1 <- readIntArray arr 0 i2 <- readIntArray arr 1 - return [ CLit (MachInt (toInteger i1) True) - , CLit (MachInt (toInteger i2) True) + return [ CLit (MachInt (toInteger i1)) + , CLit (MachInt (toInteger i2)) ] ) | otherwise -- doubles are 1 word @@ -1641,6 +1635,6 @@ doubleToWords (CLit (MachDouble r)) arr <- newDoubleArray ((0::Int),0) writeDoubleArray arr 0 (fromRational r) i <- readIntArray arr 0 - return [ CLit (MachInt (toInteger i) True) ] + return [ CLit (MachInt (toInteger i)) ] ) \end{code} diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index ded171f06b..47ad787842 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -14,13 +14,25 @@ types that \begin{code} module BasicTypes( - Version, Arity, + Version, + + Arity, + Unused, unused, + Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, negateFixity, negatePrecedence, + NewOrData(..), + RecFlag(..), isRec, isNonRec, - TopLevelFlag(..), isTopLevel, isNotTopLevel + + TopLevelFlag(..), isTopLevel, isNotTopLevel, + + OccInfo(..), seqOccInfo, isFragileOccInfo, + InsideLam, insideLam, notInsideLam, + OneBranch, oneBranch, notOneBranch + ) where #include "HsVersions.h" @@ -151,3 +163,64 @@ isNonRec :: RecFlag -> Bool isNonRec Recursive = False isNonRec NonRecursive = True \end{code} + + +%************************************************************************ +%* * +\subsection{Occurrence information} +%* * +%************************************************************************ + +This data type is used exclusively by the simplifier, but it appears in a +SubstResult, which is currently defined in VarEnv, which is pretty near +the base of the module hierarchy. So it seemed simpler to put the +defn of OccInfo here, safely at the bottom + +\begin{code} +data OccInfo + = NoOccInfo + + | IAmDead -- Marks unused variables. Sometimes useful for + -- lambda and case-bound variables. + + | OneOcc InsideLam + + OneBranch + + | IAmALoopBreaker -- Used by the occurrence analyser to mark loop-breakers + -- in a group of recursive definitions + +seqOccInfo :: OccInfo -> () +seqOccInfo (OneOcc in_lam once) = in_lam `seq` once `seq` () +seqOccInfo occ = () + +type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda + -- Substituting a redex for this occurrence is + -- dangerous because it might duplicate work. +insideLam = True +notInsideLam = False + +type OneBranch = Bool -- True <=> Occurs in only one case branch + -- so no code-duplication issue to worry about +oneBranch = True +notOneBranch = False + +isFragileOccInfo :: OccInfo -> Bool +isFragileOccInfo (OneOcc _ _) = True +isFragileOccInfo other = False +\end{code} + +\begin{code} +instance Outputable OccInfo where + -- only used for debugging; never parsed. KSW 1999-07 + ppr NoOccInfo = empty + ppr IAmALoopBreaker = ptext SLIT("_Kx") + ppr IAmDead = ptext SLIT("_Kd") + ppr (OneOcc inside_lam one_branch) | inside_lam = ptext SLIT("_Kl") + | one_branch = ptext SLIT("_Ks") + | otherwise = ptext SLIT("_Ks*") + +instance Show OccInfo where + showsPrec p occ = showsPrecSDoc p (ppr occ) +\end{code} + diff --git a/ghc/compiler/basicTypes/Const.hi-boot b/ghc/compiler/basicTypes/Const.hi-boot deleted file mode 100644 index d91fea0411..0000000000 --- a/ghc/compiler/basicTypes/Const.hi-boot +++ /dev/null @@ -1,5 +0,0 @@ -_interface_ Const 1 -_exports_ -Const Con ; -_declarations_ -1 data Con ; diff --git a/ghc/compiler/basicTypes/Const.hi-boot-5 b/ghc/compiler/basicTypes/Const.hi-boot-5 deleted file mode 100644 index 3bf4d23502..0000000000 --- a/ghc/compiler/basicTypes/Const.hi-boot-5 +++ /dev/null @@ -1,3 +0,0 @@ -__interface Const 1 0 where -__export Const Con ; -1 data Con ; diff --git a/ghc/compiler/basicTypes/Const.lhs b/ghc/compiler/basicTypes/Const.lhs deleted file mode 100644 index 22fa7f8cef..0000000000 --- a/ghc/compiler/basicTypes/Const.lhs +++ /dev/null @@ -1,434 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1998 -% -\section[Literal]{@Literal@: Machine literals (unboxed, of course)} - -\begin{code} -module Const ( - Con(..), - conType, conPrimRep, - conOkForApp, conOkForAlt, isWHNFCon, isDataCon, isBoxedDataCon, - conIsTrivial, conIsCheap, conIsDupable, conStrictness, - conOkForSpeculation, hashCon, - - DataCon, PrimOp, -- For completeness - - -- Defined here - Literal(..), -- Exported to ParseIface - mkMachInt, mkMachWord, - mkMachInt_safe, mkMachInt64, mkMachWord64, - mkStrLit, -- ToDo: rm (not used anywhere) - isNoRepLit, isLitLitLit, - literalType, literalPrimRep - ) where - -#include "HsVersions.h" - -import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, - intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy - ) -import Name ( hashName ) -import PrimOp ( PrimOp, primOpType, primOpIsDupable, primOpTag, - primOpIsCheap, primOpStrictness, primOpOkForSpeculation ) -import PrimRep ( PrimRep(..) ) -import DataCon ( DataCon, dataConName, dataConType, dataConTyCon, - isNullaryDataCon, dataConRepStrictness, isUnboxedTupleCon - ) -import TyCon ( isNewTyCon ) -import Type ( Type, typePrimRep ) -import PprType ( pprParendType ) -import Demand ( Demand ) -import CStrings ( stringToC, charToC, charToEasyHaskell ) - -import Outputable -import Util ( thenCmp ) - -import Ratio ( numerator, denominator ) -import FastString ( uniqueOfFS ) -import Char ( ord ) - -#if __GLASGOW_HASKELL__ >= 404 -import GlaExts ( fromInt ) -#endif -\end{code} - - -%************************************************************************ -%* * -\subsection{The main data type} -%* * -%************************************************************************ - -\begin{code} -data Con - = DataCon DataCon - | Literal Literal - | PrimOp PrimOp - | DEFAULT -- Used in case clauses - deriving (Eq, Ord) - --- The Ord is needed for the FiniteMap used in the lookForConstructor --- in SimplEnv. If you declared that lookForConstructor *ignores* --- constructor-applications with LitArg args, then you could get --- rid of this Ord. - -instance Outputable Con where - ppr (DataCon dc) = ppr dc - ppr (Literal lit) = ppr lit - ppr (PrimOp op) = ppr op - ppr DEFAULT = ptext SLIT("__DEFAULT") - -instance Show Con where - showsPrec p con = showsPrecSDoc p (ppr con) - -conType :: Con -> Type -conType (DataCon dc) = dataConType dc -conType (Literal lit) = literalType lit -conType (PrimOp op) = primOpType op - -conStrictness :: Con -> ([Demand], Bool) -conStrictness (DataCon dc) = (dataConRepStrictness dc, False) -conStrictness (PrimOp op) = primOpStrictness op -conStrictness (Literal lit) = ([], False) - -conPrimRep :: Con -> PrimRep -- Only data valued constants -conPrimRep (DataCon dc) = ASSERT( isNullaryDataCon dc) PtrRep -conPrimRep (Literal lit) = literalPrimRep lit - -conOkForApp, conOkForAlt :: Con -> Bool - --- OK for appliation site -conOkForApp (DataCon dc) = not (isNewTyCon (dataConTyCon dc)) -conOkForApp (Literal _) = True -conOkForApp (PrimOp op) = True -conOkForApp DEFAULT = False - --- OK for case alternative pattern -conOkForAlt (DataCon dc) = not (isNewTyCon (dataConTyCon dc)) -conOkForAlt (Literal lit) = not (isNoRepLit lit) -conOkForAlt (PrimOp _) = False -conOkForAlt DEFAULT = True - - -- isWHNFCon is false for PrimOps, which contain work - -- Ditto for newtype constructors, which can occur in the output - -- of the desugarer, but which will be inlined right away thereafter -isWHNFCon (DataCon dc) = not (isNewTyCon (dataConTyCon dc)) -isWHNFCon (Literal _) = True -isWHNFCon (PrimOp _) = False - -isDataCon (DataCon dc) = True -isDataCon other = False - -isBoxedDataCon (DataCon dc) = not (isUnboxedTupleCon dc) -isBoxedDataCon other = False - --- conIsTrivial is true for constants we are unconditionally happy to duplicate --- cf CoreUtils.exprIsTrivial -conIsTrivial (Literal lit) = not (isNoRepLit lit) -conIsTrivial (PrimOp _) = False -conIsTrivial con = True - --- conIsCheap is true for constants whose *work* we are willing --- to duplicate in exchange for some modest gain. cf CoreUtils.exprIsCheap -conIsCheap (Literal lit) = True -- Even no-rep lits are cheap; we don't end - -- up duplicating their work if we push them inside - -- a lambda, because we float them to the top in the end -conIsCheap (DataCon con) = True -conIsCheap (PrimOp op) = primOpIsCheap op - --- conIsDupable is true for constants whose applications we are willing --- to duplicate in different case branches; i.e no issue about loss of --- work, just space -conIsDupable (Literal lit) = not (isNoRepLit lit) -conIsDupable (DataCon con) = True -conIsDupable (PrimOp op) = primOpIsDupable op - --- Similarly conOkForSpeculation -conOkForSpeculation (Literal lit) = True -conOkForSpeculation (DataCon con) = True -conOkForSpeculation (PrimOp op) = primOpOkForSpeculation op -\end{code} - - -%************************************************************************ -%* * -\subsection{Literals} -%* * -%************************************************************************ - -So-called @Literals@ are {\em either}: -\begin{itemize} -\item -An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.), -which is presumed to be surrounded by appropriate constructors -(@mKINT@, etc.), so that the overall thing makes sense. -\item -An Integer, Rational, or String literal whose representation we are -{\em uncommitted} about; i.e., the surrounding with constructors, -function applications, etc., etc., has not yet been done. -\end{itemize} - -\begin{code} -data Literal - = ------------------ - -- First the primitive guys - MachChar Char - | MachStr FAST_STRING - - | MachAddr Integer -- Whatever this machine thinks is a "pointer" - - | MachInt Integer -- For the numeric types, these are - Bool -- True <=> signed (Int#); False <=> unsigned (Word#) - - | MachInt64 Integer -- guaranteed 64-bit versions of the above. - Bool -- True <=> signed (Int#); False <=> unsigned (Word#) - - - | MachFloat Rational - | MachDouble Rational - - | MachLitLit FAST_STRING Type -- Type might be Add# or Int# etc - - ------------------ - -- The no-rep guys - | NoRepStr FAST_STRING Type -- This Type is always String - | NoRepInteger Integer Type -- This Type is always Integer - | NoRepRational Rational Type -- This Type is always Rational - -- We keep these Types in the literal because Rational isn't - -- (currently) wired in, so we can't conjure up its type out of - -- thin air. Integer is, so the type here is really redundant. -\end{code} - -\begin{code} -instance Outputable Literal where - ppr lit = pprLit lit - -instance Show Literal where - showsPrec p lit = showsPrecSDoc p (ppr lit) - -instance Eq Literal where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - -instance Ord Literal where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = cmpLit a b -\end{code} - - - Construction - ~~~~~~~~~~~~ -\begin{code} -mkMachInt, mkMachWord :: Integer -> Literal - -mkMachInt x = MachInt x True{-signed-} -mkMachWord x = MachInt x False{-unsigned-} - --- check if the int is within range -mkMachInt_safe :: Integer -> Literal -mkMachInt_safe i - | out_of_range = - pprPanic "mkMachInt_safe" - (hsep [text "ERROR: Int ", text (show i), text "out of range", - brackets (int minInt <+> text ".." <+> int maxInt)]) - | otherwise = MachInt i True{-signed-} - where - out_of_range = --- i < fromInt minBound || - i > fromInt maxInt - -mkMachInt64 x = MachInt64 x True{-signed-} -mkMachWord64 x = MachInt64 x False{-unsigned-} - -mkStrLit :: String -> Type -> Literal -mkStrLit s ty = NoRepStr (_PK_ s) ty -\end{code} - - - Predicates - ~~~~~~~~~~ -\begin{code} -isNoRepLit (NoRepStr _ _) = True -- these are not primitive typed! -isNoRepLit (NoRepInteger _ _) = True -isNoRepLit (NoRepRational _ _) = True -isNoRepLit _ = False - -isLitLitLit (MachLitLit _ _) = True -isLitLitLit _ = False -\end{code} - - Types - ~~~~~ -\begin{code} -literalType :: Literal -> Type -literalType (MachChar _) = charPrimTy -literalType (MachStr _) = addrPrimTy -literalType (MachAddr _) = addrPrimTy -literalType (MachInt _ signed) = if signed then intPrimTy else wordPrimTy -literalType (MachInt64 _ signed) = if signed then int64PrimTy else word64PrimTy -literalType (MachFloat _) = floatPrimTy -literalType (MachDouble _) = doublePrimTy -literalType (MachLitLit _ ty) = ty -literalType (NoRepInteger _ ty) = ty -literalType (NoRepRational _ ty) = ty -literalType (NoRepStr _ ty) = ty -\end{code} - -\begin{code} -literalPrimRep :: Literal -> PrimRep - -literalPrimRep (MachChar _) = CharRep -literalPrimRep (MachStr _) = AddrRep -- specifically: "char *" -literalPrimRep (MachAddr _) = AddrRep -literalPrimRep (MachInt _ signed) = if signed then IntRep else WordRep -literalPrimRep (MachInt64 _ signed) = if signed then Int64Rep else Word64Rep -literalPrimRep (MachFloat _) = FloatRep -literalPrimRep (MachDouble _) = DoubleRep -literalPrimRep (MachLitLit _ ty) = typePrimRep ty -#ifdef DEBUG -literalPrimRep (NoRepInteger _ _) = panic "literalPrimRep:NoRepInteger" -literalPrimRep (NoRepRational _ _) = panic "literalPrimRep:NoRepRational" -literalPrimRep (NoRepStr _ _) = panic "literalPrimRep:NoRepString" -#endif -\end{code} - - - Comparison - ~~~~~~~~~~ -\begin{code} -cmpLit (MachChar a) (MachChar b) = a `compare` b -cmpLit (MachStr a) (MachStr b) = a `compare` b -cmpLit (MachAddr a) (MachAddr b) = a `compare` b -cmpLit (MachInt a b) (MachInt c d) = (a `compare` c) `thenCmp` (b `compare` d) -cmpLit (MachFloat a) (MachFloat b) = a `compare` b -cmpLit (MachDouble a) (MachDouble b) = a `compare` b -cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `compare` d) -cmpLit (NoRepStr a _) (NoRepStr b _) = a `compare` b -cmpLit (NoRepInteger a _) (NoRepInteger b _) = a `compare` b -cmpLit (NoRepRational a _) (NoRepRational b _) = a `compare` b -cmpLit lit1 lit2 | litTag lit1 _LT_ litTag lit2 = LT - | otherwise = GT - -litTag (MachChar _) = ILIT(1) -litTag (MachStr _) = ILIT(2) -litTag (MachAddr _) = ILIT(3) -litTag (MachInt _ _) = ILIT(4) -litTag (MachFloat _) = ILIT(5) -litTag (MachDouble _) = ILIT(6) -litTag (MachLitLit _ _) = ILIT(7) -litTag (NoRepStr _ _) = ILIT(8) -litTag (NoRepInteger _ _) = ILIT(9) -litTag (NoRepRational _ _) = ILIT(10) -\end{code} - - Printing - ~~~~~~~~ -* MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo") - exceptions: MachFloat and MachAddr get an initial keyword prefix - -* NoRep things get an initial keyword prefix (e.g. _integer_ 3) - -\begin{code} -pprLit lit - = getPprStyle $ \ sty -> - let - code_style = codeStyle sty - in - case lit of - MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), char '\'', - text (charToC ch), char '\''] - | ifaceStyle sty -> char '\'' <> text (charToEasyHaskell ch) <> char '\'' - | otherwise -> text ['\'', ch, '\''] - - MachStr s | code_style -> doubleQuotes (text (stringToC (_UNPK_ s))) - | otherwise -> pprFSAsString s - - - NoRepStr s ty | code_style -> pprPanic "NoRep in code style" (ppr lit) - | otherwise -> ptext SLIT("__string") <+> pprFSAsString s - - MachInt i signed | code_style && out_of_range - -> pprPanic "" (hsep [text "ERROR: Int ", text (show i), - text "out of range", - brackets (ppr range_min <+> text ".." - <+> ppr range_max)]) - -- in interface files, parenthesize raw negative ints. - -- this avoids problems like {-1} being interpreted - -- as a comment starter. -} - | ifaceStyle sty && i < 0 -> parens (integer i) - -- avoid a problem whereby gcc interprets the constant - -- minInt as unsigned. - | code_style && i == (toInteger (minBound :: Int)) - -> parens (hcat [integer (i+1), text "-1"]) - | otherwise -> integer i - - where - range_min = if signed then minInt else 0 - range_max = maxInt - out_of_range = not (i >= toInteger range_min && i <= toInteger range_max) - - MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> rational f - | otherwise -> ptext SLIT("__float") <+> rational f - - MachDouble d | ifaceStyle sty && d < 0 -> parens (rational d) - | otherwise -> rational d - - MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p - | otherwise -> ptext SLIT("__addr") <+> integer p - - NoRepInteger i _ | code_style -> pprPanic "NoRep in code style" (ppr lit) - | otherwise -> ptext SLIT("__integer") <+> integer i - - NoRepRational r _ | code_style -> pprPanic "NoRep in code style" (ppr lit) - | otherwise -> hsep [ptext SLIT("__rational"), integer (numerator r), - integer (denominator r)] - - MachLitLit s ty | code_style -> ptext s - | otherwise -> parens (hsep [ptext SLIT("__litlit"), - pprFSAsString s, - pprParendType ty]) -\end{code} - - -%************************************************************************ -%* * -\subsection{Hashing -%* * -%************************************************************************ - -Hash values should be zero or a positive integer. No negatives please. -(They mess up the UniqFM for some reason.) - -\begin{code} -hashCon :: Con -> Int -hashCon (DataCon dc) = hashName (dataConName dc) -hashCon (PrimOp op) = primOpTag op + 500 -- Keep it out of range of common ints -hashCon (Literal lit) = hashLiteral lit -hashCon other = pprTrace "hashCon" (ppr other) 0 - -hashLiteral :: Literal -> Int -hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints -hashLiteral (MachStr s) = hashFS s -hashLiteral (MachAddr i) = hashInteger i -hashLiteral (MachInt i _) = hashInteger i -hashLiteral (MachInt64 i _) = hashInteger i -hashLiteral (MachFloat r) = hashRational r -hashLiteral (MachDouble r) = hashRational r -hashLiteral (MachLitLit s _) = hashFS s -hashLiteral (NoRepStr s _) = hashFS s -hashLiteral (NoRepInteger i _) = hashInteger i -hashLiteral (NoRepRational r _) = hashRational r - -hashRational :: Rational -> Int -hashRational r = hashInteger (numerator r) - -hashInteger :: Integer -> Int -hashInteger i = abs (fromInteger (i `rem` 10000)) - -hashFS :: FAST_STRING -> Int -hashFS s = IBOX( uniqueOfFS s ) -\end{code} - diff --git a/ghc/compiler/basicTypes/DataCon.hi-boot b/ghc/compiler/basicTypes/DataCon.hi-boot index f11d4e47c3..9a19a92759 100644 --- a/ghc/compiler/basicTypes/DataCon.hi-boot +++ b/ghc/compiler/basicTypes/DataCon.hi-boot @@ -1,7 +1,7 @@ _interface_ DataCon 1 _exports_ -DataCon DataCon dataConType isExistentialDataCon ; +DataCon DataCon dataConRepType isExistentialDataCon ; _declarations_ 1 data DataCon ; -1 dataConType _:_ DataCon -> TypeRep.Type ;; +1 dataConRepType _:_ DataCon -> TypeRep.Type ;; 1 isExistentialDataCon _:_ DataCon -> PrelBase.Bool ;; diff --git a/ghc/compiler/basicTypes/DataCon.hi-boot-5 b/ghc/compiler/basicTypes/DataCon.hi-boot-5 index ea08f44b1c..cbd894c12f 100644 --- a/ghc/compiler/basicTypes/DataCon.hi-boot-5 +++ b/ghc/compiler/basicTypes/DataCon.hi-boot-5 @@ -1,5 +1,5 @@ __interface DataCon 1 0 where -__export DataCon DataCon dataConType isExistentialDataCon ; +__export DataCon DataCon dataConRepType isExistentialDataCon ; 1 data DataCon ; -1 dataConType :: DataCon -> TypeRep.Type ; +1 dataConRepType :: DataCon -> TypeRep.Type ; 1 isExistentialDataCon :: DataCon -> PrelBase.Bool ; diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index e1aa7d6b3f..f44f932e18 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -8,13 +8,16 @@ module DataCon ( DataCon, ConTag, fIRST_TAG, mkDataCon, - dataConType, dataConSig, dataConName, dataConTag, dataConTyCon, + dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon, dataConArgTys, dataConOrigArgTys, - dataConRawArgTys, dataConAllRawArgTys, - dataConFieldLabels, dataConStrictMarks, dataConSourceArity, - dataConNumFields, dataConNumInstArgs, dataConId, dataConRepStrictness, - isNullaryDataCon, isTupleCon, isUnboxedTupleCon, - isExistentialDataCon, splitProductType_maybe, + dataConRepArgTys, + dataConFieldLabels, dataConStrictMarks, + dataConSourceArity, dataConRepArity, + dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness, + isNullaryDataCon, isTupleCon, isUnboxedTupleCon, isDynDataCon, + isExistentialDataCon, + + splitProductType_maybe, splitProductType, StrictnessMark(..), -- Representation visible to MkId only markedStrict, notMarkedStrict, markedUnboxed, maybeMarkedUnboxed @@ -27,15 +30,14 @@ import {-# SOURCE #-} Subst( substTy, mkTyVarSubst ) import CmdLineOpts ( opt_DictsStrict ) import TysPrim import Type ( Type, ThetaType, TauType, ClassContext, - mkSigmaTy, mkFunTys, mkTyConApp, + mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTys, mkDictTy, splitAlgTyConApp_maybe, classesToPreds ) -import PprType import TyCon ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon, - isTupleTyCon, isUnboxedTupleTyCon ) + isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon ) import Class ( classTyCon ) -import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined ) +import Name ( Name, NamedThing(..), nameUnique, isDynName, isLocallyDefined ) import Var ( TyVar, Id ) import FieldLabel ( FieldLabel ) import BasicTypes ( Arity ) @@ -43,6 +45,7 @@ import Demand ( Demand, wwStrict, wwLazy ) import Outputable import Unique ( Unique, Uniquable(..) ) import CmdLineOpts ( opt_UnboxStrictFields ) +import PprType () -- Instances import UniqSet import Maybes ( maybeToBool ) import Maybe @@ -50,6 +53,24 @@ import Util ( assoc ) \end{code} +Stuff about data constructors +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every constructor, C, comes with a + + *wrapper*, called C, whose type is exactly what it looks like + in the source program. It is an ordinary function, + and it gets a top-level binding like any other function + + *worker*, called $wC, which is the actual data constructor. + Its type may be different to C, because: + - useless dict args are dropped + - strict args may be flattened + It does not have a binding. + + The worker is very like a primop, in that it has no binding, + + + %************************************************************************ %* * \subsection{Data constructors} @@ -68,7 +89,7 @@ data DataCon -- -- data Eq a => T a = forall b. Ord b => MkT a [b] - dcType :: Type, -- Type of the constructor + dcRepType :: Type, -- Type of the constructor -- forall ab . Ord b => a -> [b] -> MkT a -- (this is *not* of the constructor Id: -- see notes after this data type declaration) @@ -92,32 +113,39 @@ data DataCon dcOrigArgTys :: [Type], -- Original argument types -- (before unboxing and flattening of -- strict fields) - dcRepArgTys :: [Type], -- Constructor Argument types + + dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening, + -- and including existential dictionaries + dcTyCon :: TyCon, -- Result tycon -- Now the strictness annotations and field labels of the constructor dcUserStricts :: [StrictnessMark], -- Strictness annotations, as placed on the data type defn, -- in the same order as the argument types; - -- length = dataConNumFields dataCon + -- length = dataConSourceArity dataCon dcRealStricts :: [StrictnessMark], -- Strictness annotations as deduced by the compiler. May - -- include some MarkedUnboxed fields that are MarkedStrict - -- in dcUserStricts. - -- length = dataConNumFields dataCon + -- include some MarkedUnboxed fields that are merely MarkedStrict + -- in dcUserStricts. Also includes the existential dictionaries. + -- length = length dcExTheta + dataConSourceArity dataCon dcFields :: [FieldLabel], -- Field labels for this constructor, in the -- same order as the argument types; -- length = 0 (if not a record) or dataConSourceArity. - -- Finally, the curried function that corresponds to the constructor - -- mkT :: forall a b. (Eq a, Ord b) => a -> [b] -> T a - -- mkT = /\ab. \deq dord p qs. Con MkT [a, b, dord, p, qs] - -- This unfolding is built in MkId.mkDataConId + -- Finally, the curried worker function that corresponds to the constructor + -- It doesn't have an unfolding; the code generator saturates these Ids + -- and allocates a real constructor when it finds one. + -- + -- An entirely separate wrapper function is built in TcTyDecls + + dcId :: Id, -- The corresponding worker Id + -- Takes dcRepArgTys as its arguments - dcId :: Id -- The corresponding Id + dcWrapId :: Id -- The wrapper Id } type ConTag = Int @@ -126,7 +154,7 @@ fIRST_TAG :: ConTag fIRST_TAG = 1 -- Tags allocated from here for real constructors \end{code} -The dcType field contains the type of the representation of a contructor +The dcRepType field contains the type of the representation of a contructor This may differ from the type of the contructor *Id* (built by MkId.mkDataConId) for two reasons: a) the constructor Id may be overloaded, but the dictionary isn't stored @@ -207,11 +235,13 @@ mkDataCon :: Name -> [TyVar] -> ClassContext -> [TyVar] -> ClassContext -> [TauType] -> TyCon - -> Id + -> Id -> Id -> DataCon -- Can get the tag from the TyCon -mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta orig_arg_tys tycon id +mkDataCon name arg_stricts fields + tyvars theta ex_tyvars ex_theta orig_arg_tys tycon + work_id wrap_id = ASSERT(length arg_stricts == length orig_arg_tys) -- The 'stricts' passed to mkDataCon are simply those for the -- source-language arguments. We add extra ones for the @@ -224,12 +254,12 @@ mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta orig_arg_tys t dcRepArgTys = rep_arg_tys, dcExTyVars = ex_tyvars, dcExTheta = ex_theta, dcRealStricts = all_stricts, dcUserStricts = user_stricts, - dcFields = fields, dcTag = tag, dcTyCon = tycon, dcType = ty, - dcId = id} + dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty, + dcId = work_id, dcWrapId = wrap_id} (real_arg_stricts, strict_arg_tyss) = unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys) - rep_arg_tys = concat strict_arg_tyss + rep_arg_tys = [mkDictTy cls tys | (cls,tys) <- ex_theta] ++ concat strict_arg_tyss ex_dict_stricts = map mk_dict_strict_mark ex_theta -- Add a strictness flag for the existential dictionary arguments @@ -237,10 +267,11 @@ mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta orig_arg_tys t user_stricts = ex_dict_stricts ++ arg_stricts tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con - ty = mkSigmaTy (tyvars ++ ex_tyvars) - (classesToPreds ex_theta) - (mkFunTys rep_arg_tys - (mkTyConApp tycon (mkTyVarTys tyvars))) + ty = mkForAllTys (tyvars ++ ex_tyvars) + (mkFunTys rep_arg_tys result_ty) + -- NB: the existential dict args are already in rep_arg_tys + + result_ty = mkTyConApp tycon (mkTyVarTys tyvars) mk_dict_strict_mark (clas,tys) | opt_DictsStrict && @@ -259,12 +290,14 @@ dataConTag = dcTag dataConTyCon :: DataCon -> TyCon dataConTyCon = dcTyCon -dataConType :: DataCon -> Type -dataConType = dcType +dataConRepType :: DataCon -> Type +dataConRepType = dcRepType dataConId :: DataCon -> Id dataConId = dcId +dataConWrapId :: DataCon -> Id +dataConWrapId = dcWrapId dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels = dcFields @@ -272,10 +305,23 @@ dataConFieldLabels = dcFields dataConStrictMarks :: DataCon -> [StrictnessMark] dataConStrictMarks = dcRealStricts +-- Number of type-instantiation arguments +-- All the remaining arguments of the DataCon are (notionally) +-- stored in the DataCon, and are matched in a case expression +dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars + dataConSourceArity :: DataCon -> Arity -- Source-level arity of the data constructor dataConSourceArity dc = length (dcOrigArgTys dc) +-- dataConRepArity gives the number of actual fields in the +-- {\em representation} of the data constructor. This may be more than appear +-- in the source code; the extra ones are the existentially quantified +-- dictionaries +dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys + +isNullaryDataCon con = dataConRepArity con == 0 + dataConRepStrictness :: DataCon -> [Demand] -- Give the demands on the arguments of a -- Core constructor application (Con dc args) @@ -302,48 +348,31 @@ dataConArgTys :: DataCon -> [Type] -- Needs arguments of these types -- NB: these INCLUDE the existentially quantified dict args -- but EXCLUDE the data-decl context which is discarded + -- It's all post-flattening etc; this is a representation type dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars, - dcExTyVars = ex_tyvars, dcExTheta = ex_theta}) inst_tys - = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) - ([mkDictTy cls tys | (cls,tys) <- ex_theta] ++ arg_tys) + dcExTyVars = ex_tyvars}) inst_tys + = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys \end{code} These two functions get the real argument types of the constructor, -without substituting for any type variables. dataConAllRawArgTys is -like dataConRawArgTys except that the existential dictionary arguments -are included. dataConOrigArgTys is the same, but returns the types -written by the programmer. +without substituting for any type variables. + +dataConOrigArgTys returns the arg types of the wrapper, excluding all dictionary args. + +dataConRepArgTys retuns the arg types of the worker, including all dictionaries, and +after any flattening has been done. \begin{code} dataConOrigArgTys :: DataCon -> [Type] dataConOrigArgTys dc = dcOrigArgTys dc -dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience -dataConRawArgTys dc = dcRepArgTys dc - -dataConAllRawArgTys :: DataCon -> [TauType] -dataConAllRawArgTys con = - [mkDictTy cls tys | (cls,tys) <- dcExTheta con] ++ dcRepArgTys con +dataConRepArgTys :: DataCon -> [TauType] +dataConRepArgTys dc = dcRepArgTys dc \end{code} -dataConNumFields gives the number of actual fields in the -{\em representation} of the data constructor. This may be more than appear -in the source code; the extra ones are the existentially quantified -dictionaries \begin{code} --- Number of type-instantiation arguments --- All the remaining arguments of the DataCon are (notionally) --- stored in the DataCon, and are matched in a case expression -dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars - -dataConNumFields (MkData {dcExTheta = theta, dcRepArgTys = arg_tys}) - = length theta + length arg_tys - -isNullaryDataCon con - = dataConNumFields con == 0 -- function of convenience - isTupleCon :: DataCon -> Bool isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc @@ -352,6 +381,9 @@ isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc isExistentialDataCon :: DataCon -> Bool isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs) + +isDynDataCon :: DataCon -> Bool +isDynDataCon con = isDynName (dataConName con) \end{code} @@ -371,7 +403,6 @@ splitProductType_maybe -- Returns (Just ...) for any -- single-constructor - -- non-recursive type -- not existentially quantified -- type whether a data type or a new type -- @@ -382,13 +413,14 @@ splitProductType_maybe splitProductType_maybe ty = case splitAlgTyConApp_maybe ty of Just (tycon,ty_args,[data_con]) - | isProductTyCon tycon -- Checks for non-recursive, non-existential - -> Just (tycon, ty_args, data_con, data_con_arg_tys) - where - data_con_arg_tys = map (substTy (mkTyVarSubst (dcTyVars data_con) ty_args)) - (dcRepArgTys data_con) + | isProductTyCon tycon -- Includes check for non-existential + -> Just (tycon, ty_args, data_con, dataConArgTys data_con ty_args) other -> Nothing +splitProductType str ty + = case splitProductType_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic (str ++ ": not a product") (ppr ty) -- We attempt to unbox/unpack a strict field when either: -- (i) The tycon is imported, and the field is marked '! !', or @@ -408,6 +440,7 @@ unbox_strict_arg_ty tycon strict_mark ty MarkedStrict -> opt_UnboxStrictFields && isLocallyDefined tycon && maybeToBool maybe_product && + not (isRecursiveTyCon tycon) && isDataTyCon arg_tycon -- We can't look through newtypes in arguments (yet) = (MarkedUnboxed con arg_tys, arg_tys) diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index cb45ddcd4a..7f376fd326 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -10,7 +10,13 @@ module Demand( wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum, isStrict, isLazy, isPrim, - pprDemands, seqDemand, seqDemands + pprDemands, seqDemand, seqDemands, + + StrictnessInfo(..), + mkStrictnessInfo, + noStrictnessInfo, + ppStrictnessInfo, seqStrictnessInfo, + isBottomingStrictness, appIsBottom, ) where #include "HsVersions.h" @@ -134,49 +140,71 @@ instance Outputable Demand where instance Show Demand where showsPrec p d = showsPrecSDoc p (ppr d) + +-- Reading demands is done in Lex.lhs \end{code} +%************************************************************************ +%* * +\subsection[strictness-IdInfo]{Strictness info about an @Id@} +%* * +%************************************************************************ + +We specify the strictness of a function by giving information about +each of the ``wrapper's'' arguments (see the description about +worker/wrapper-style transformations in the PJ/Launchbury paper on +unboxed types). + +The list of @Demands@ specifies: (a)~the strictness properties of a +function's arguments; and (b)~the type signature of that worker (if it +exists); i.e. its calling convention. + +Note that the existence of a worker function is now denoted by the Id's +workerInfo field. + +\begin{code} +data StrictnessInfo + = NoStrictnessInfo + + | StrictnessInfo [Demand] -- Demands on the arguments. + + Bool -- True <=> the function diverges regardless of its arguments + -- Useful for "error" and other disguised variants thereof. + -- BUT NB: f = \x y. error "urk" + -- will have info SI [SS] True + -- but still (f) and (f 2) are not bot; only (f 3 2) is bot + + -- NOTA BENE: if the arg demands are, say, [S,L], this means that + -- (f bot) is not necy bot, only (f bot x) is bot + -- We simply cannot express accurately the strictness of a function + -- like f = \x -> case x of (a,b) -> \y -> ... + -- The up-side is that we don't need to restrict the strictness info + -- to the visible arity of the function. + +seqStrictnessInfo :: StrictnessInfo -> () +seqStrictnessInfo (StrictnessInfo ds b) = b `seq` seqDemands ds +seqStrictnessInfo other = () +\end{code} + \begin{code} -{- ------------------- OMITTED NOW ------------------------------- - -- Reading demands is done in Lex.lhs - -- Also note that the (old) code here doesn't take proper - -- account of the 'B' suffix for bottoming functions +mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo -#ifdef REALLY_HASKELL_1_3 +mkStrictnessInfo (xs, is_bot) + | all isLazy xs && not is_bot = NoStrictnessInfo -- Uninteresting + | otherwise = StrictnessInfo xs is_bot -instance Read Demand where - readList str = read_em [] str +noStrictnessInfo = NoStrictnessInfo -instance Show Demand where - showsPrec p d = showsPrecSDoc p (ppr d) +isBottomingStrictness (StrictnessInfo _ bot) = bot +isBottomingStrictness NoStrictnessInfo = False -#else +-- appIsBottom returns true if an application to n args would diverge +appIsBottom (StrictnessInfo ds bot) n = bot && (n >= length ds) +appIsBottom NoStrictnessInfo n = False -instance Text Demand where - readList str = read_em [] str - showsPrec p d = showsPrecSDoc p (ppr d) -#endif - -readDemands :: String -> - -read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs -read_em acc ('A' : xs) = read_em (WwLazy True : acc) xs -read_em acc ('S' : xs) = read_em (WwStrict : acc) xs -read_em acc ('P' : xs) = read_em (WwPrim : acc) xs -read_em acc ('E' : xs) = read_em (WwEnum : acc) xs -read_em acc (')' : xs) = [(reverse acc, xs)] -read_em acc ( 'U' : '(' : xs) = do_unpack DataType True acc xs -read_em acc ( 'u' : '(' : xs) = do_unpack DataType False acc xs -read_em acc ( 'N' : '(' : xs) = do_unpack NewType True acc xs -read_em acc ( 'n' : '(' : xs) = do_unpack NewType False acc xs -read_em acc rest = [(reverse acc, rest)] - -do_unpack new_or_data wrapper_unpacks acc xs - = case (read_em [] xs) of - [(stuff, rest)] -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest - _ -> pprPanic "Demand.do_unpack:" (ppr acc <+> dcolon <> text xs) - --------------------- END OF OMISSION ------------------------------ -} +ppStrictnessInfo NoStrictnessInfo = empty +ppStrictnessInfo (StrictnessInfo wrapper_args bot) + = hsep [ptext SLIT("__S"), pprDemands wrapper_args bot] \end{code} diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index a0a85ddf52..15c7c63958 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -19,7 +19,8 @@ import Unique ( Uniquable(..) ) data FieldLabel = FieldLabel Name -- Also used as the Name of the field selector Id Type -- Type of the field; may have free type variables that - -- are the tyvar of the constructor + -- are the tyvars of its parent *data* constructor, and + -- those will be the same as the tyvars of its parent *type* constructor -- e.g. data T a = MkT { op1 :: a -> a, op2 :: a -> Int } -- The type in the FieldLabel for op1 will be simply (a->a). diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 814fcb7ee4..389631a6ba 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -22,18 +22,19 @@ module Id ( zapFragileIdInfo, zapLamIdInfo, -- Predicates - omitIfaceSigForId, + omitIfaceSigForId, isDeadBinder, exportWithOrigOccName, externallyVisibleId, idFreeTyVars, isIP, -- Inline pragma stuff - getInlinePragma, setInlinePragma, modifyInlinePragma, + idInlinePragma, setInlinePragma, modifyInlinePragma, isSpecPragmaId, isRecordSelector, - isPrimitiveId_maybe, isDataConId_maybe, - isConstantId, isConstantId_maybe, isBottomingId, idAppIsBottom, + isPrimOpId, isPrimOpId_maybe, + isDataConId, isDataConId_maybe, isDataConWrapId, isDataConWrapId_maybe, + isBottomingId, isExportedId, isUserExportedId, mayHaveNoBinding, @@ -42,7 +43,7 @@ module Id ( -- IdInfo stuff setIdUnfolding, - setIdArity, + setIdArityInfo, setIdDemandInfo, setIdStrictness, setIdWorkerInfo, @@ -52,16 +53,18 @@ module Id ( setIdCprInfo, setIdOccInfo, - getIdArity, - getIdDemandInfo, - getIdStrictness, - getIdWorkerInfo, - getIdUnfolding, - getIdSpecialisation, - getIdUpdateInfo, - getIdCafInfo, - getIdCprInfo, - getIdOccInfo + idArity, idArityInfo, + idFlavour, + idDemandInfo, + idStrictness, + idWorkerInfo, + idUnfolding, + idSpecialisation, + idUpdateInfo, + idCafInfo, + idCprInfo, + idLBVarInfo, + idOccInfo ) where @@ -70,6 +73,7 @@ module Id ( import {-# SOURCE #-} CoreUnfold ( Unfolding ) import {-# SOURCE #-} CoreSyn ( CoreRules ) +import BasicTypes ( Arity ) import Var ( Id, DictId, isId, mkIdVar, idName, idType, idUnique, idInfo, @@ -89,9 +93,8 @@ import Name ( Name, OccName, getOccName, isIPOcc ) import OccName ( UserFS ) -import Const ( Con(..) ) import PrimRep ( PrimRep ) -import PrimOp ( PrimOp ) +import PrimOp ( PrimOp, primOpIsCheap ) import TysPrim ( statePrimTyCon ) import FieldLabel ( FieldLabel(..) ) import SrcLoc ( SrcLoc ) @@ -99,15 +102,15 @@ import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques ) import Outputable infixl 1 `setIdUnfolding`, - `setIdArity`, + `setIdArityInfo`, `setIdDemandInfo`, `setIdStrictness`, `setIdWorkerInfo`, `setIdSpecialisation`, `setIdUpdateInfo`, `setInlinePragma`, - `getIdCafInfo`, - `getIdCprInfo` + `idCafInfo`, + `idCprInfo` -- infixl so you can say (id `set` a `set` b) \end{code} @@ -207,27 +210,38 @@ isRecordSelector id = case idFlavour id of RecordSelId lbl -> True other -> False -isPrimitiveId_maybe id = case idFlavour id of - ConstantId (PrimOp op) -> Just op - other -> Nothing +isPrimOpId id = case idFlavour id of + PrimOpId op -> True + other -> False + +isPrimOpId_maybe id = case idFlavour id of + PrimOpId op -> Just op + other -> Nothing + +isDataConId id = case idFlavour id of + DataConId _ -> True + other -> False isDataConId_maybe id = case idFlavour id of - ConstantId (DataCon con) -> Just con - other -> Nothing + DataConId con -> Just con + other -> Nothing -isConstantId id = case idFlavour id of - ConstantId _ -> True - other -> False +isDataConWrapId_maybe id = case idFlavour id of + DataConWrapId con -> Just con + other -> Nothing -isConstantId_maybe id = case idFlavour id of - ConstantId const -> Just const - other -> Nothing +isDataConWrapId id = case idFlavour id of + DataConWrapId con -> True + other -> False isSpecPragmaId id = case idFlavour id of SpecPragmaId -> True other -> False -mayHaveNoBinding id = isConstantId id +mayHaveNoBinding id = case idFlavour id of + DataConId _ -> True + PrimOpId _ -> True + other -> False -- mayHaveNoBinding returns True of an Id which may not have a -- binding, even though it is defined in this module. Notably, -- the constructors of a dictionary are in this situation. @@ -261,9 +275,11 @@ omitIfaceSigForId id | otherwise = case idFlavour id of - RecordSelId _ -> True -- Includes dictionary selectors - ConstantId _ -> True - -- ConstantIds are implied by their type or class decl; + RecordSelId _ -> True -- Includes dictionary selectors + PrimOpId _ -> True + DataConId _ -> True + DataConWrapId _ -> True + -- These are are implied by their type or class decl; -- remember that all type and class decls appear in the interface file. -- The dfun id must *not* be omitted, because it carries version info for -- the instance decl @@ -275,12 +291,19 @@ omitIfaceSigForId id -- or an explicit user export. exportWithOrigOccName :: Id -> Bool exportWithOrigOccName id = omitIfaceSigForId id || isUserExportedId id +\end{code} + +\begin{code} +isDeadBinder :: Id -> Bool +isDeadBinder bndr | isId bndr = case idOccInfo bndr of + IAmDead -> True + other -> False + | otherwise = False -- TyVars count as not dead isIP id = isIPOcc (getOccName id) \end{code} - %************************************************************************ %* * \subsection{IdInfo stuff} @@ -290,87 +313,87 @@ isIP id = isIPOcc (getOccName id) \begin{code} --------------------------------- -- ARITY -getIdArity :: Id -> ArityInfo -getIdArity id = arityInfo (idInfo id) +idArityInfo :: Id -> ArityInfo +idArityInfo id = arityInfo (idInfo id) + +idArity :: Id -> Arity +idArity id = arityLowerBound (idArityInfo id) -setIdArity :: Id -> ArityInfo -> Id -setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id +setIdArityInfo :: Id -> ArityInfo -> Id +setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id --------------------------------- -- STRICTNESS -getIdStrictness :: Id -> StrictnessInfo -getIdStrictness id = strictnessInfo (idInfo id) +idStrictness :: Id -> StrictnessInfo +idStrictness id = strictnessInfo (idInfo id) setIdStrictness :: Id -> StrictnessInfo -> Id setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id -- isBottomingId returns true if an application to n args would diverge isBottomingId :: Id -> Bool -isBottomingId id = isBottomingStrictness (strictnessInfo (idInfo id)) - -idAppIsBottom :: Id -> Int -> Bool -idAppIsBottom id n = appIsBottom (strictnessInfo (idInfo id)) n +isBottomingId id = isBottomingStrictness (idStrictness id) --------------------------------- -- WORKER ID -getIdWorkerInfo :: Id -> WorkerInfo -getIdWorkerInfo id = workerInfo (idInfo id) +idWorkerInfo :: Id -> WorkerInfo +idWorkerInfo id = workerInfo (idInfo id) setIdWorkerInfo :: Id -> WorkerInfo -> Id setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id --------------------------------- -- UNFOLDING -getIdUnfolding :: Id -> Unfolding -getIdUnfolding id = unfoldingInfo (idInfo id) +idUnfolding :: Id -> Unfolding +idUnfolding id = unfoldingInfo (idInfo id) setIdUnfolding :: Id -> Unfolding -> Id setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id --------------------------------- -- DEMAND -getIdDemandInfo :: Id -> Demand -getIdDemandInfo id = demandInfo (idInfo id) +idDemandInfo :: Id -> Demand +idDemandInfo id = demandInfo (idInfo id) setIdDemandInfo :: Id -> Demand -> Id setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id --------------------------------- -- UPDATE INFO -getIdUpdateInfo :: Id -> UpdateInfo -getIdUpdateInfo id = updateInfo (idInfo id) +idUpdateInfo :: Id -> UpdateInfo +idUpdateInfo id = updateInfo (idInfo id) setIdUpdateInfo :: Id -> UpdateInfo -> Id setIdUpdateInfo id upd_info = modifyIdInfo (`setUpdateInfo` upd_info) id --------------------------------- -- SPECIALISATION -getIdSpecialisation :: Id -> CoreRules -getIdSpecialisation id = specInfo (idInfo id) +idSpecialisation :: Id -> CoreRules +idSpecialisation id = specInfo (idInfo id) setIdSpecialisation :: Id -> CoreRules -> Id setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id --------------------------------- -- CAF INFO -getIdCafInfo :: Id -> CafInfo -getIdCafInfo id = cafInfo (idInfo id) +idCafInfo :: Id -> CafInfo +idCafInfo id = cafInfo (idInfo id) setIdCafInfo :: Id -> CafInfo -> Id setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id --------------------------------- -- CPR INFO -getIdCprInfo :: Id -> CprInfo -getIdCprInfo id = cprInfo (idInfo id) +idCprInfo :: Id -> CprInfo +idCprInfo id = cprInfo (idInfo id) setIdCprInfo :: Id -> CprInfo -> Id setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id --------------------------------- -- Occcurrence INFO -getIdOccInfo :: Id -> OccInfo -getIdOccInfo id = occInfo (idInfo id) +idOccInfo :: Id -> OccInfo +idOccInfo id = occInfo (idInfo id) setIdOccInfo :: Id -> OccInfo -> Id setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id @@ -383,8 +406,8 @@ The inline pragma tells us to be very keen to inline this Id, but it's still OK not to if optimisation is switched off. \begin{code} -getInlinePragma :: Id -> InlinePragInfo -getInlinePragma id = inlinePragInfo (idInfo id) +idInlinePragma :: Id -> InlinePragInfo +idInlinePragma id = inlinePragInfo (idInfo id) setInlinePragma :: Id -> InlinePragInfo -> Id setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id @@ -397,8 +420,11 @@ modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn ( --------------------------------- -- ONE-SHOT LAMBDAS \begin{code} +idLBVarInfo :: Id -> LBVarInfo +idLBVarInfo id = lbvarInfo (idInfo id) + isOneShotLambda :: Id -> Bool -isOneShotLambda id = case lbvarInfo (idInfo id) of +isOneShotLambda id = case idLBVarInfo id of IsOneShotLambda -> True NoLBVarInfo -> case splitTyConApp_maybe (idType id) of Just (tycon,_) -> tycon == statePrimTyCon diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index f899847e18..8546357412 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -25,15 +25,15 @@ module IdInfo ( exactArity, atLeastArity, unknownArity, hasArity, arityInfo, setArityInfo, ppArityInfo, arityLowerBound, - -- Strictness - StrictnessInfo(..), -- Non-abstract - mkStrictnessInfo, - noStrictnessInfo, strictnessInfo, - ppStrictnessInfo, setStrictnessInfo, - isBottomingStrictness, appIsBottom, + -- Strictness; imported from Demand + StrictnessInfo(..), + mkStrictnessInfo, noStrictnessInfo, + ppStrictnessInfo,isBottomingStrictness, appIsBottom, + + strictnessInfo, setStrictnessInfo, -- Worker - WorkerInfo, workerExists, + WorkerInfo(..), workerExists, wrapperArity, workerId, workerInfo, setWorkerInfo, ppWorkerInfo, -- Unfolding @@ -47,8 +47,9 @@ module IdInfo ( inlinePragInfo, setInlinePragInfo, pprInlinePragInfo, -- Occurrence info - OccInfo(..), InsideLam, OneBranch, insideLam, notInsideLam, oneBranch, notOneBranch, - occInfo, setOccInfo, isFragileOccInfo, + OccInfo(..), isFragileOccInfo, + InsideLam, OneBranch, insideLam, notInsideLam, oneBranch, notOneBranch, + occInfo, setOccInfo, -- Specialisation specInfo, setSpecInfo, @@ -72,12 +73,17 @@ module IdInfo ( import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding, hasUnfolding, seqUnfolding ) import {-# SOURCE #-} CoreSyn ( CoreExpr, CoreRules, emptyCoreRules, isEmptyCoreRules, seqRules ) -import {-# SOURCE #-} Const ( Con ) +import PrimOp ( PrimOp ) import Var ( Id ) -import VarSet ( IdOrTyVarSet ) +import BasicTypes ( OccInfo(..), isFragileOccInfo, seqOccInfo, + InsideLam, insideLam, notInsideLam, + OneBranch, oneBranch, notOneBranch, + Arity + ) +import DataCon ( DataCon ) import FieldLabel ( FieldLabel ) -import Demand ( Demand, isStrict, isLazy, wwLazy, pprDemands, seqDemand, seqDemands ) +import Demand -- Lots of stuff import Outputable import Maybe ( isJust ) @@ -135,12 +141,12 @@ seqIdInfo (IdInfo {}) = () megaSeqIdInfo :: IdInfo -> () megaSeqIdInfo info - = seqFlavour (flavourInfo info) `seq` - seqArity (arityInfo info) `seq` - seqDemand (demandInfo info) `seq` - seqRules (specInfo info) `seq` - seqStrictness (strictnessInfo info) `seq` - seqWorker (workerInfo info) `seq` + = seqFlavour (flavourInfo info) `seq` + seqArity (arityInfo info) `seq` + seqDemand (demandInfo info) `seq` + seqRules (specInfo info) `seq` + seqStrictnessInfo (strictnessInfo info) `seq` + seqWorker (workerInfo info) `seq` -- seqUnfolding (unfoldingInfo info) `seq` -- Omitting this improves runtimes a little, presumably because @@ -179,7 +185,6 @@ setNoDiscardInfo info = case flavourInfo info of zapSpecPragInfo info = case flavourInfo info of SpecPragmaId -> info { flavourInfo = VanillaId } other -> info - \end{code} @@ -193,7 +198,7 @@ mkIdInfo flv = IdInfo { arityInfo = UnknownArity, demandInfo = wwLazy, specInfo = emptyCoreRules, - workerInfo = Nothing, + workerInfo = NoWorker, strictnessInfo = NoStrictnessInfo, unfoldingInfo = noUnfolding, updateInfo = NoUpdateInfo, @@ -214,18 +219,26 @@ mkIdInfo flv = IdInfo { \begin{code} data IdFlavour - = VanillaId -- Most Ids are like this - | ConstantId Con -- The Id for a constant (data constructor or primop) - | RecordSelId FieldLabel -- The Id for a record selector - | SpecPragmaId -- Don't discard these - | NoDiscardId -- Don't discard these either + = VanillaId -- Most Ids are like this + | DataConId DataCon -- The Id for a data constructor *worker* + | DataConWrapId DataCon -- The Id for a data constructor *wrapper* + -- [the only reasons we need to know is so that + -- a) we can suppress printing a definition in the interface file + -- b) when typechecking a pattern we can get from the + -- Id back to the data con] + | PrimOpId PrimOp -- The Id for a primitive operator + | RecordSelId FieldLabel -- The Id for a record selector + | SpecPragmaId -- Don't discard these + | NoDiscardId -- Don't discard these either ppFlavourInfo :: IdFlavour -> SDoc -ppFlavourInfo VanillaId = empty -ppFlavourInfo (ConstantId _) = ptext SLIT("[Constr]") -ppFlavourInfo (RecordSelId _) = ptext SLIT("[RecSel]") -ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]") -ppFlavourInfo NoDiscardId = ptext SLIT("[NoDiscard]") +ppFlavourInfo VanillaId = empty +ppFlavourInfo (DataConId _) = ptext SLIT("[DataCon]") +ppFlavourInfo (DataConWrapId _) = ptext SLIT("[DataConWrapper]") +ppFlavourInfo (PrimOpId _) = ptext SLIT("[PrimOp]") +ppFlavourInfo (RecordSelId _) = ptext SLIT("[RecSel]") +ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]") +ppFlavourInfo NoDiscardId = ptext SLIT("[NoDiscard]") seqFlavour :: IdFlavour -> () seqFlavour f = f `seq` () @@ -256,11 +269,11 @@ besides the code-generator need arity info!) data ArityInfo = UnknownArity -- No idea - | ArityExactly Int -- Arity is exactly this. We use this when importing a + | ArityExactly Arity -- Arity is exactly this. We use this when importing a -- function; it's already been compiled and we know its -- arity for sure. - | ArityAtLeast Int -- Arity is this or greater. We attach this arity to + | ArityAtLeast Arity -- Arity is this or greater. We attach this arity to -- functions in the module being compiled. Their arity -- might increase later in the compilation process, if -- an extra lambda floats up to the binding site. @@ -272,7 +285,7 @@ exactArity = ArityExactly atLeastArity = ArityAtLeast unknownArity = UnknownArity -arityLowerBound :: ArityInfo -> Int +arityLowerBound :: ArityInfo -> Arity arityLowerBound UnknownArity = 0 arityLowerBound (ArityAtLeast n) = n arityLowerBound (ArityExactly n) = n @@ -317,115 +330,6 @@ instance Show InlinePragInfo where %************************************************************************ %* * -\subsection{Occurrence information} -%* * -%************************************************************************ - -\begin{code} -data OccInfo - = NoOccInfo - - | IAmDead -- Marks unused variables. Sometimes useful for - -- lambda and case-bound variables. - - | OneOcc InsideLam - - OneBranch - - | IAmALoopBreaker -- Used by the occurrence analyser to mark loop-breakers - -- in a group of recursive definitions - -seqOccInfo :: OccInfo -> () -seqOccInfo (OneOcc in_lam once) = in_lam `seq` once `seq` () -seqOccInfo occ = () - -type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda - -- Substituting a redex for this occurrence is - -- dangerous because it might duplicate work. -insideLam = True -notInsideLam = False - -type OneBranch = Bool -- True <=> Occurs in only one case branch - -- so no code-duplication issue to worry about -oneBranch = True -notOneBranch = False - -isFragileOccInfo :: OccInfo -> Bool -isFragileOccInfo (OneOcc _ _) = True -isFragileOccInfo other = False -\end{code} - -\begin{code} -instance Outputable OccInfo where - -- only used for debugging; never parsed. KSW 1999-07 - ppr NoOccInfo = empty - ppr IAmALoopBreaker = ptext SLIT("_Kx") - ppr IAmDead = ptext SLIT("_Kd") - ppr (OneOcc inside_lam one_branch) | inside_lam = ptext SLIT("_Kl") - | one_branch = ptext SLIT("_Ks") - | otherwise = ptext SLIT("_Ks*") - -instance Show OccInfo where - showsPrec p occ = showsPrecSDoc p (ppr occ) -\end{code} - -%************************************************************************ -%* * -\subsection[strictness-IdInfo]{Strictness info about an @Id@} -%* * -%************************************************************************ - -We specify the strictness of a function by giving information about -each of the ``wrapper's'' arguments (see the description about -worker/wrapper-style transformations in the PJ/Launchbury paper on -unboxed types). - -The list of @Demands@ specifies: (a)~the strictness properties of a -function's arguments; and (b)~the type signature of that worker (if it -exists); i.e. its calling convention. - -Note that the existence of a worker function is now denoted by the Id's -workerInfo field. - -\begin{code} -data StrictnessInfo - = NoStrictnessInfo - - | StrictnessInfo [Demand] - Bool -- True <=> the function diverges regardless of its arguments - -- Useful for "error" and other disguised variants thereof. - -- BUT NB: f = \x y. error "urk" - -- will have info SI [SS] True - -- but still (f) and (f 2) are not bot; only (f 3 2) is bot - -seqStrictness :: StrictnessInfo -> () -seqStrictness (StrictnessInfo ds b) = b `seq` seqDemands ds -seqStrictness other = () -\end{code} - -\begin{code} -mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo - -mkStrictnessInfo (xs, is_bot) - | all isLazy xs && not is_bot = NoStrictnessInfo -- Uninteresting - | otherwise = StrictnessInfo xs is_bot - -noStrictnessInfo = NoStrictnessInfo - -isBottomingStrictness (StrictnessInfo _ bot) = bot -isBottomingStrictness NoStrictnessInfo = False - --- appIsBottom returns true if an application to n args would diverge -appIsBottom (StrictnessInfo ds bot) n = bot && (n >= length ds) -appIsBottom NoStrictnessInfo n = False - -ppStrictnessInfo NoStrictnessInfo = empty -ppStrictnessInfo (StrictnessInfo wrapper_args bot) - = hsep [ptext SLIT("__S"), pprDemands wrapper_args bot] -\end{code} - -%************************************************************************ -%* * \subsection[worker-IdInfo]{Worker info about an @Id@} %* * %************************************************************************ @@ -441,24 +345,31 @@ There might not be a worker, even for a strict function, because: \begin{code} -type WorkerInfo = Maybe Id - -{- UNUSED: -mkWorkerInfo :: Id -> WorkerInfo -mkWorkerInfo wk_id = Just wk_id --} +data WorkerInfo = NoWorker + | HasWorker Id Arity + -- The Arity is the arity of the *wrapper* at the moment of the + -- w/w split. It had better be the same as the arity of the wrapper + -- at the moment it is spat into the interface file. + -- This Arity just lets us make a (hopefully redundant) sanity check seqWorker :: WorkerInfo -> () -seqWorker (Just id) = id `seq` () -seqWorker Nothing = () +seqWorker (HasWorker id _) = id `seq` () +seqWorker NoWorker = () -ppWorkerInfo Nothing = empty -ppWorkerInfo (Just wk_id) = ptext SLIT("__P") <+> ppr wk_id +ppWorkerInfo NoWorker = empty +ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("__P") <+> ppr wk_id -noWorkerInfo = Nothing +noWorkerInfo = NoWorker workerExists :: WorkerInfo -> Bool -workerExists = isJust +workerExists NoWorker = False +workerExists (HasWorker _ _) = True + +workerId :: WorkerInfo -> Id +workerId (HasWorker id _) = id + +wrapperArity :: WorkerInfo -> Arity +wrapperArity (HasWorker _ a) = a \end{code} @@ -553,41 +464,25 @@ also CPRs. \begin{code} data CprInfo = NoCPRInfo - - | CPRInfo [CprInfo] - --- e.g. const 5 == CPRInfo [NoCPRInfo] --- == __M(-) --- \x -> (5, --- (x, --- 5, --- x) --- ) --- CPRInfo [CPRInfo [NoCPRInfo], --- CPRInfo [NoCprInfo, --- CPRInfo [NoCPRInfo], --- NoCPRInfo] --- ] --- __M((-)(-(-)-)-) + | ReturnsCPR -- Yes, this function returns a constructed product + -- Implicitly, this means "after the function has been applied + -- to all its arguments", so the worker/wrapper builder in + -- WwLib.mkWWcpr checks that that it is indeed saturated before + -- making use of the CPR info + + -- We used to keep nested info about sub-components, but + -- we never used it so I threw it away \end{code} \begin{code} seqCpr :: CprInfo -> () -seqCpr (CPRInfo cs) = seqCprs cs -seqCpr NoCPRInfo = () - -seqCprs [] = () -seqCprs (c:cs) = seqCpr c `seq` seqCprs cs - +seqCpr ReturnsCPR = () +seqCpr NoCPRInfo = () noCprInfo = NoCPRInfo -ppCprInfo NoCPRInfo = empty -ppCprInfo c@(CPRInfo _) - = hsep [ptext SLIT("__M"), ppCprInfo' c] - where - ppCprInfo' NoCPRInfo = char '-' - ppCprInfo' (CPRInfo args) = parens (hcat (map ppCprInfo' args)) +ppCprInfo NoCPRInfo = empty +ppCprInfo ReturnsCPR = ptext SLIT("__M") instance Outputable CprInfo where ppr = ppCprInfo diff --git a/ghc/compiler/basicTypes/MkId.hi-boot b/ghc/compiler/basicTypes/MkId.hi-boot index 1069e9e711..6af0340e1c 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot +++ b/ghc/compiler/basicTypes/MkId.hi-boot @@ -1,6 +1,6 @@ _interface_ MkId 1 _exports_ -MkId mkDataConId mkPrimitiveId ; +MkId mkDataConId mkDataConWrapId ; _declarations_ -1 mkDataConId _:_ DataCon.DataCon -> Var.Id ;; -1 mkPrimitiveId _:_ PrimOp.PrimOp -> Var.Id ;; +1 mkDataConId _:_ Name.Name -> DataCon.DataCon -> Var.Id ;; +1 mkDataConWrapId _:_ DataCon.DataCon -> Var.Id ;; diff --git a/ghc/compiler/basicTypes/MkId.hi-boot-5 b/ghc/compiler/basicTypes/MkId.hi-boot-5 index 10a40e8942..3d56963592 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot-5 +++ b/ghc/compiler/basicTypes/MkId.hi-boot-5 @@ -1,5 +1,5 @@ __interface MkId 1 0 where -__export MkId mkDataConId mkPrimitiveId ; -1 mkDataConId :: DataCon.DataCon -> Var.Id ; -1 mkPrimitiveId :: PrimOp.PrimOp -> Var.Id ; +__export MkId mkDataConId mkDataConWrapId ; +1 mkDataConId :: Name.Name -> DataCon.DataCon -> Var.Id ; +1 mkDataConWrapId :: DataCon.DataCon -> Var.Id ; diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 6cd2af3cc0..871b77df37 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -18,10 +18,9 @@ module MkId ( mkDictFunId, mkDefaultMethodId, mkDictSelId, - mkDataConId, + mkDataConId, mkDataConWrapId, mkRecordSelId, - mkNewTySelId, - mkPrimitiveId, + mkPrimOpId, mkCCallOpId, -- And some particular Ids; see below for why they are wired in wiredInIds, @@ -43,41 +42,47 @@ import PrelRules ( primOpRule ) import Rules ( addRule ) import Type ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy, classesToPreds, - isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes, + isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes, splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp, splitFunTys, splitForAllTys, unUsgTy, mkUsgTy, UsageAnn(..) ) +import PprType ( pprParendType ) import Module ( Module ) -import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding ) +import CoreUtils ( mkInlineMe ) +import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon ) import Subst ( mkTopTyVarSubst, substClasses ) -import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon ) +import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, isDataTyCon, isProductTyCon, isUnboxedTupleTyCon ) import Class ( Class, classBigSig, classTyCon, classTyVars, classSelIds ) import Var ( Id, TyVar ) import VarSet ( isEmptyVarSet ) -import Const ( Con(..) ) import Name ( mkDerivedName, mkWiredInIdName, mkLocalName, - mkWorkerOcc, mkSuperDictSelOcc, + mkWorkerOcc, mkSuperDictSelOcc, mkCCallName, Name, NamedThing(..), ) import OccName ( mkSrcVarOcc ) -import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName, primOpArity, primOpStrictness ) -import Demand ( wwStrict ) -import DataCon ( DataCon, StrictnessMark(..), dataConStrictMarks, dataConFieldLabels, - dataConArgTys, dataConSig, dataConRawArgTys +import PrimOp ( PrimOp(DataToTagOp, CCallOp), + primOpSig, mkPrimOpIdName, + CCall, pprCCallOp + ) +import Demand ( wwStrict, wwPrim ) +import DataCon ( DataCon, StrictnessMark(..), + dataConFieldLabels, dataConRepArity, dataConTyCon, + dataConArgTys, dataConRepType, dataConRepStrictness, dataConName, + dataConSig, dataConStrictMarks, dataConId ) import Id ( idType, mkId, mkVanillaId, mkTemplateLocals, - mkTemplateLocal, setInlinePragma + mkTemplateLocal, setInlinePragma, idCprInfo ) -import IdInfo ( vanillaIdInfo, mkIdInfo, - exactArity, setUnfoldingInfo, setCafInfo, +import IdInfo ( IdInfo, vanillaIdInfo, mkIdInfo, + exactArity, setUnfoldingInfo, setCafInfo, setCprInfo, setArityInfo, setInlinePragInfo, setSpecInfo, mkStrictnessInfo, setStrictnessInfo, - IdFlavour(..), InlinePragInfo(..), CafInfo(..), IdInfo + IdFlavour(..), InlinePragInfo(..), CafInfo(..), StrictnessInfo(..), CprInfo(..) ) import FieldLabel ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName, - firstFieldLabelTag, allFieldLabelTags + firstFieldLabelTag, allFieldLabelTags, fieldLabelType ) import CoreSyn import Maybes @@ -148,18 +153,41 @@ mkWorkerId uniq unwrkr ty %************************************************************************ \begin{code} -mkDataConId :: DataCon -> Id -mkDataConId data_con - = mkId (getName data_con) - id_ty - (dataConInfo data_con) +mkDataConId :: Name -> DataCon -> Id + -- Makes the *worker* for the data constructor; that is, the function + -- that takes the reprsentation arguments and builds the constructor. +mkDataConId work_name data_con + = mkId work_name (dataConRepType data_con) info where - (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con - id_ty = mkSigmaTy (tyvars ++ ex_tyvars) - (classesToPreds (theta ++ ex_theta)) - (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))) + info = mkIdInfo (DataConId data_con) + `setArityInfo` exactArity arity + `setStrictnessInfo` strict_info + `setCprInfo` cpr_info + + arity = dataConRepArity data_con + + strict_info = StrictnessInfo (dataConRepStrictness data_con) False + + cpr_info | isProductTyCon tycon && + not (isUnboxedTupleTyCon tycon) && + arity > 0 = ReturnsCPR + | otherwise = NoCPRInfo + where + tycon = dataConTyCon data_con + -- Newtypes don't have a worker at all + -- + -- If we are a product with 0 args we must be void(like) + -- We can't create an unboxed tuple with 0 args for this + -- and since Void has only one, constant value it should + -- just mean returning a pointer to a pre-existing cell. + -- So we won't really gain from doing anything fancy + -- and we treat this case as Top. \end{code} +The wrapper for a constructor is an ordinary top-level binding that evaluates +any strict args, unboxes any args that are going to be flattened, and calls +the worker. + We're going to build a constructor that looks like: data (Data a, C b) => T a b = T1 !a !Int b @@ -194,61 +222,95 @@ Notice that it in the (common) case where the constructor arg is already evaluated. \begin{code} -dataConInfo :: DataCon -> IdInfo - -dataConInfo data_con - = mkIdInfo (ConstantId (DataCon data_con)) - `setArityInfo` exactArity (n_dicts + n_ex_dicts + n_id_args) - `setUnfoldingInfo` unfolding +mkDataConWrapId data_con + = wrap_id where - unfolding = mkTopUnfolding (Note InlineMe con_rhs) - -- The dictionary constructors of a class don't get a binding, - -- but they are always saturated, so they should always be inlined. - - (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) - = dataConSig data_con - rep_arg_tys = dataConRawArgTys data_con - all_tyvars = tyvars ++ ex_tyvars - - dict_tys = [mkDictTy clas tys | (clas,tys) <- theta] - ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta] - - n_dicts = length dict_tys - n_ex_dicts = length ex_dict_tys - n_id_args = length orig_arg_tys - n_rep_args = length rep_arg_tys - - result_ty = mkTyConApp tycon (mkTyVarTys tyvars) - - mkLocals i n tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) - (dict_args, i1) = mkLocals 1 n_dicts dict_tys - (ex_dict_args,i2) = mkLocals i1 n_ex_dicts ex_dict_tys - (id_args,i3) = mkLocals i2 n_id_args orig_arg_tys - - (id_arg1:_) = id_args -- Used for newtype only - strict_marks = dataConStrictMarks data_con - - con_app i rep_ids - | isNewTyCon tycon - = ASSERT( length orig_arg_tys == 1 ) - Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1) - | otherwise - = mkConApp data_con - (map Type (mkTyVarTys all_tyvars) ++ - map Var (reverse rep_ids)) - - con_rhs = mkLams all_tyvars $ mkLams dict_args $ - mkLams ex_dict_args $ mkLams id_args $ - foldr mk_case con_app + wrap_id = mkId (dataConName data_con) wrap_ty info + work_id = dataConId data_con + + info = mkIdInfo (DataConWrapId data_con) + `setUnfoldingInfo` mkTopUnfolding cpr_info (mkInlineMe wrap_rhs) + `setCprInfo` cpr_info + -- The Cpr info can be important inside INLINE rhss, where the + -- wrapper constructor isn't inlined + `setArityInfo` exactArity arity + -- It's important to specify the arity, so that partial + -- applications are treated as values + `setCafInfo` NoCafRefs + -- The wrapper Id ends up in STG code as an argument, + -- sometimes before its definition, so we want to + -- signal that it has no CAFs + + wrap_ty = mkForAllTys all_tyvars $ + mkFunTys all_arg_tys + result_ty + + cpr_info = idCprInfo work_id + + wrap_rhs | isNewTyCon tycon + = ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 ) + -- No existentials on a newtype, but it can have a contex + -- e.g. newtype Eq a => T a = MkT (...) + + mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $ + Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1) + +{- I nuked this because map (:) xs would create a + new local lambda for the (:) in core-to-stg. + There isn't a defn for the worker! + + | null dict_args && all not_marked_strict strict_marks + = Var work_id -- The common case. Not only is this efficient, + -- but it also ensures that the wrapper is replaced + -- by the worker even when there are no args. + -- f (:) x + -- becomes + -- f $w: x + -- This is really important in rule matching, + -- which is a bit sad. (We could match on the wrappers, + -- but that makes it less likely that rules will match + -- when we bring bits of unfoldings together +-} + + | otherwise + = mkLams all_tyvars $ mkLams dict_args $ + mkLams ex_dict_args $ mkLams id_args $ + foldr mk_case con_app (zip (ex_dict_args++id_args) strict_marks) i3 [] - mk_case + con_app i rep_ids = mkApps (Var work_id) + (map varToCoreExpr (all_tyvars ++ reverse rep_ids)) + + (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con + all_tyvars = tyvars ++ ex_tyvars + + dict_tys = [mkDictTy clas tys | (clas,tys) <- theta] + ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta] + all_arg_tys = dict_tys ++ ex_dict_tys ++ orig_arg_tys + result_ty = mkTyConApp tycon (mkTyVarTys tyvars) + + mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) + where + n = length tys + + (dict_args, i1) = mkLocals 1 dict_tys + (ex_dict_args,i2) = mkLocals i1 ex_dict_tys + (id_args,i3) = mkLocals i2 orig_arg_tys + arity = i3-1 + (id_arg1:_) = id_args -- Used for newtype only + + strict_marks = dataConStrictMarks data_con + not_marked_strict NotMarkedStrict = True + not_marked_strict other = False + + + mk_case :: (Id, StrictnessMark) -- arg, strictness -> (Int -> [Id] -> CoreExpr) -- body -> Int -- next rep arg id -> [Id] -- rep args so far -> CoreExpr - mk_case (arg,strict) body i rep_args + mk_case (arg,strict) body i rep_args = case strict of NotMarkedStrict -> body i (arg:rep_args) MarkedStrict @@ -257,10 +319,10 @@ dataConInfo data_con Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))] MarkedUnboxed con tys -> - Case (Var arg) arg [(DataCon con, con_args, + Case (Var arg) arg [(DataAlt con, con_args, body i' (reverse con_args++rep_args))] where n_tys = length tys - (con_args,i') = mkLocals i (length tys) tys + (con_args,i') = mkLocals i tys \end{code} @@ -282,25 +344,33 @@ We're going to build a record selector unfolding that looks like this: other -> error "..." \begin{code} -mkRecordSelId field_label selector_ty - = ASSERT( null theta && isDataTyCon tycon ) - sel_id +mkRecordSelId tycon field_label + -- Assumes that all fields with the same field label + -- have the same type + = sel_id where - sel_id = mkId (fieldLabelName field_label) selector_ty info + sel_id = mkId (fieldLabelName field_label) selector_ty info + + field_ty = fieldLabelType field_label + field_name = fieldLabelName field_label + data_cons = tyConDataCons tycon + tyvars = tyConTyVars tycon -- These scope over the types in + -- the FieldLabels of constructors of this type + data_ty = mkTyConApp tycon (mkTyVarTys tyvars) + tyvar_tys = mkTyVarTys tyvars + + selector_ty :: Type + selector_ty = mkForAllTys tyvars (mkFunTy data_ty field_ty) + info = mkIdInfo (RecordSelId field_label) `setArityInfo` exactArity 1 `setUnfoldingInfo` unfolding - + `setCafInfo` NoCafRefs -- ToDo: consider adding further IdInfo - unfolding = mkTopUnfolding sel_rhs + unfolding = mkTopUnfolding NoCPRInfo sel_rhs - (tyvars, theta, tau) = splitSigmaTy selector_ty - (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau) - -- tau is of form (T a b c -> field-type) - (tycon, _, data_cons) = splitAlgTyConApp data_ty - tyvar_tys = mkTyVarTys tyvars [data_id] = mkTemplateLocals [data_ty] alts = map mk_maybe_alt data_cons @@ -308,20 +378,26 @@ mkRecordSelId field_label selector_ty default_alt | all isJust alts = [] -- No default needed | otherwise = [(DEFAULT, [], error_expr)] - sel_rhs = mkLams tyvars $ Lam data_id $ - Case (Var data_id) data_id (the_alts ++ default_alt) + sel_rhs | isNewTyCon tycon = new_sel_rhs + | otherwise = data_sel_rhs + + data_sel_rhs = mkLams tyvars $ Lam data_id $ + Case (Var data_id) data_id (the_alts ++ default_alt) + + new_sel_rhs = mkLams tyvars $ Lam data_id $ + Note (Coerce (unUsgTy field_ty) (unUsgTy data_ty)) (Var data_id) mk_maybe_alt data_con = case maybe_the_arg_id of Nothing -> Nothing - Just the_arg_id -> Just (DataCon data_con, arg_ids, Var the_arg_id) + Just the_arg_id -> Just (DataAlt data_con, arg_ids, Var the_arg_id) where arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys) -- The first one will shadow data_id, but who cares field_lbls = dataConFieldLabels data_con maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label - error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy rhs_ty), mkStringLit full_msg] + error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_ty), mkStringLit full_msg] -- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04. full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id]) \end{code} @@ -329,46 +405,14 @@ mkRecordSelId field_label selector_ty %************************************************************************ %* * -\subsection{Newtype field selectors} -%* * -%************************************************************************ - -Possibly overkill to do it this way: - -\begin{code} -mkNewTySelId field_label selector_ty = sel_id - where - sel_id = mkId (fieldLabelName field_label) selector_ty info - - - info = mkIdInfo (RecordSelId field_label) - `setArityInfo` exactArity 1 - `setUnfoldingInfo` unfolding - - -- ToDo: consider adding further IdInfo - - unfolding = mkTopUnfolding sel_rhs - - (tyvars, theta, tau) = splitSigmaTy selector_ty - (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau) - -- tau is of form (T a b c -> field-type) - (tycon, _, data_cons) = splitAlgTyConApp data_ty - tyvar_tys = mkTyVarTys tyvars - - [data_id] = mkTemplateLocals [data_ty] - sel_rhs = mkLams tyvars $ Lam data_id $ - Note (Coerce (unUsgTy rhs_ty) (unUsgTy data_ty)) (Var data_id) -\end{code} - - -%************************************************************************ -%* * \subsection{Dictionary selectors} %* * %************************************************************************ Selecting a field for a dictionary. If there is just one field, then -there's nothing to do. +there's nothing to do. + +ToDo: unify with mkRecordSelId. \begin{code} mkDictSelId name clas ty @@ -379,12 +423,14 @@ mkDictSelId name clas ty tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id info = mkIdInfo (RecordSelId field_lbl) + `setArityInfo` exactArity 1 `setUnfoldingInfo` unfolding + `setCafInfo` NoCafRefs -- We no longer use 'must-inline' on record selectors. They'll -- inline like crazy if they scrutinise a constructor - unfolding = mkTopUnfolding rhs + unfolding = mkTopUnfolding NoCPRInfo rhs tyvars = classTyVars clas @@ -401,7 +447,7 @@ mkDictSelId name clas ty Note (Coerce (head arg_tys) dict_ty) (Var dict_id) | otherwise = mkLams tyvars $ Lam dict_id $ Case (Var dict_id) dict_id - [(DataCon data_con, arg_ids, Var the_arg_id)] + [(DataAlt data_con, arg_ids, Var the_arg_id)] \end{code} @@ -412,40 +458,54 @@ mkDictSelId name clas ty %************************************************************************ \begin{code} -mkPrimitiveId :: PrimOp -> Id -mkPrimitiveId prim_op +mkPrimOpId :: PrimOp -> Id +mkPrimOpId prim_op = id where - (tyvars,arg_tys,res_ty) = primOpSig prim_op + (tyvars,arg_tys,res_ty, arity, strict_info) = primOpSig prim_op ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) name = mkPrimOpIdName prim_op id id = mkId name ty info - info = mkIdInfo (ConstantId (PrimOp prim_op)) - `setUnfoldingInfo` unfolding + info = mkIdInfo (PrimOpId prim_op) + `setSpecInfo` rules + `setArityInfo` exactArity arity + `setStrictnessInfo` strict_info --- Not yet... --- `setSpecInfo` rules --- `setArityInfo` exactArity arity --- `setStrictnessInfo` strict_info + rules = addRule id emptyCoreRules (primOpRule prim_op) - arity = primOpArity prim_op - (dmds, result_bot) = primOpStrictness prim_op - strict_info = mkStrictnessInfo (take arity dmds, result_bot) - -- primOpStrictness can return an infinite list of demands - -- (cheap hack) but Ids mustn't have such things. - -- What a mess. - rules = addRule id emptyCoreRules (primOpRule prim_op) +-- For each ccall we manufacture a separate CCallOpId, giving it +-- a fresh unique, a type that is correct for this particular ccall, +-- and a CCall structure that gives the correct details about calling +-- convention etc. +-- +-- The *name* of this Id is a local name whose OccName gives the full +-- details of the ccall, type and all. This means that the interface +-- file reader can reconstruct a suitable Id + +mkCCallOpId :: Unique -> CCall -> Type -> Id +mkCCallOpId uniq ccall ty + = ASSERT( isEmptyVarSet (tyVarsOfType ty) ) + -- A CCallOpId should have no free type variables; + -- when doing substitutions won't substitute over it + mkId name ty info + where + occ_str = showSDocIface (braces (pprCCallOp ccall <+> ppr ty)) + -- The "occurrence name" of a ccall is the full info about the + -- ccall; it is encoded, but may have embedded spaces etc! - unfolding = mkCompulsoryUnfolding rhs - -- The mkCompulsoryUnfolding says that this Id absolutely - -- must be inlined. It's only used for primitives, - -- because we don't want to make a closure for each of them. + name = mkCCallName uniq occ_str + prim_op = CCallOp ccall - args = mkTemplateLocals arg_tys - rhs = mkLams tyvars $ mkLams args $ - mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args) + info = mkIdInfo (PrimOpId prim_op) + `setArityInfo` exactArity arity + `setStrictnessInfo` strict_info + + (_, tau) = splitForAllTys ty + (arg_tys, _) = splitFunTys tau + arity = length arg_tys + strict_info = mkStrictnessInfo (take arity (repeat wwPrim), False) \end{code} @@ -547,8 +607,9 @@ getTagId ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy) [x,y] = mkTemplateLocals [alphaTy,alphaTy] rhs = mkLams [alphaTyVar,x] $ - Case (Var x) y [ (DEFAULT, [], - Con (PrimOp DataToTagOp) [Type alphaTy, Var y]) ] + Case (Var x) y [ (DEFAULT, [], mkApps (Var dataToTagId) [Type alphaTy, Var y]) ] + +dataToTagId = mkPrimOpId DataToTagOp \end{code} @realWorld#@ used to be a magic literal, \tr{void#}. If things get @@ -558,7 +619,11 @@ nasty as-is, change it back to a literal (@Literal@). realWorldPrimId -- :: State# RealWorld = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#") realWorldStatePrimTy - noCafIdInfo + (noCafIdInfo `setUnfoldingInfo` mkOtherCon []) + -- The mkOtherCon makes it look that realWorld# is evaluated + -- which in turn makes Simplify.interestingArg return True, + -- which in turn makes INLINE things applied to realWorld# likely + -- to be inlined \end{code} diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 721325d33f..bbdb46a2f5 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -10,7 +10,7 @@ module Name ( -- The Name type Name, -- Abstract - mkLocalName, mkImportedLocalName, mkSysLocalName, + mkLocalName, mkImportedLocalName, mkSysLocalName, mkCCallName, mkTopName, mkIPName, mkDerivedName, mkGlobalName, mkKnownKeyGlobal, mkWiredInIdName, mkWiredInTyConName, @@ -21,8 +21,8 @@ module Name ( tidyTopName, nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, - isUserExportedName, isUserImportedExplicitlyName, nameSrcLoc, - isLocallyDefinedName, + isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, nameSrcLoc, + isLocallyDefinedName, isDynName, isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, @@ -43,7 +43,7 @@ import {-# SOURCE #-} Var ( Id, setIdName ) import {-# SOURCE #-} TyCon ( TyCon, setTyConName ) import OccName -- All of it -import Module ( Module, moduleName, pprModule, mkVanillaModule ) +import Module ( Module, moduleName, pprModule, mkVanillaModule, isDynamicModule ) import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) @@ -118,6 +118,12 @@ mkSysLocalName :: Unique -> UserFS -> Name mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = Local, n_occ = mkSrcVarOcc fs, n_prov = systemProvenance } +mkCCallName :: Unique -> EncodedString -> Name + -- The encoded string completely describes the ccall +mkCCallName uniq str = Name { n_uniq = uniq, n_sort = Local, + n_occ = mkCCallOcc str, + n_prov = NonLocalDef ImplicitImport True } + mkTopName :: Unique -> Module -> FAST_STRING -> Name -- Make a top-level name; make it Global if top-level -- things should be externally visible; Local otherwise @@ -410,6 +416,14 @@ isUserExportedName other = False isUserImportedExplicitlyName (Name { n_prov = NonLocalDef (UserImport _ _ explicit) _ }) = explicit isUserImportedExplicitlyName other = False +isUserImportedName (Name { n_prov = NonLocalDef (UserImport _ _ _) _ }) = True +isUserImportedName other = False + +isDynName :: Name -> Bool + -- Does this name come from a DLL? +isDynName nm = not (isLocallyDefinedName nm) && + isDynamicModule (nameModule nm) + nameSrcLoc name = provSrcLoc (n_prov name) provSrcLoc (LocalDef loc _) = loc diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 2977362328..5b1ed18516 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -14,12 +14,12 @@ module OccName ( OccName, -- Abstract, instance of Outputable pprOccName, - mkSrcOccFS, mkSysOcc, mkSysOccFS, mkSrcVarOcc, mkKindOccFS, + mkSrcOccFS, mkSysOcc, mkSysOccFS, mkCCallOcc, mkSrcVarOcc, mkKindOccFS, mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, - isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, + isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc, occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, setOccNameSpace, @@ -162,13 +162,20 @@ already encoded \begin{code} mkSysOcc :: NameSpace -> EncodedString -> OccName -mkSysOcc occ_sp str = ASSERT( alreadyEncoded str ) +mkSysOcc occ_sp str = ASSERT2( alreadyEncoded str, text str ) OccName occ_sp (_PK_ str) mkSysOccFS :: NameSpace -> EncodedFS -> OccName mkSysOccFS occ_sp fs = ASSERT2( alreadyEncodedFS fs, ppr fs ) OccName occ_sp fs +mkCCallOcc :: EncodedString -> OccName +-- This version of mkSysOcc doesn't check that the string is already encoded, +-- because it will be something like "{__ccall f dyn Int# -> Int#}" +-- This encodes a lot into something that then parses like an Id. +-- But then alreadyEncoded complains about the braces! +mkCCallOcc str = OccName varName (_PK_ str) + -- Kind constructors get a speical function. Uniquely, they are not encoded, -- so that they have names like '*'. This means that *even in interface files* -- we'll get kinds like (* -> (* -> *)). We can't use mkSysOcc because it @@ -225,13 +232,17 @@ isTvOcc other = False isUvOcc (OccName UvName _) = True isUvOcc other = False +isValOcc (OccName VarName _) = True +isValOcc (OccName DataName _) = True +isValOcc other = False + -- Data constructor operator (starts with ':', or '[]') -- Pretty inefficient! isDataSymOcc (OccName DataName s) = isLexConSym (decodeFS s) isDataSymOcc other = False isDataOcc (OccName DataName _) = True -isDataOcc oter = False +isDataOcc other = False -- Any operator (data constructor or variable) -- Pretty inefficient! @@ -446,6 +457,10 @@ alreadyEncoded :: String -> Bool alreadyEncoded s = all ok s where ok '_' = True + ok ' ' = True -- This is a bit of a lie; if we really wanted spaces + -- in names we'd have to encode them. But we do put + -- spaces in ccall "occurrences", and we don't want to + -- reject them here ok ch = ISALPHANUM ch alreadyEncodedFS :: FAST_STRING -> Bool diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs index ed06d2ce15..a2df826fa7 100644 --- a/ghc/compiler/basicTypes/PprEnv.lhs +++ b/ghc/compiler/basicTypes/PprEnv.lhs @@ -10,13 +10,13 @@ module PprEnv ( initPprEnv, - pCon, pBndr, pOcc, pSCC, + pBndr, pOcc, pSCC, pTy, pTyVarO ) where #include "HsVersions.h" -import {-# SOURCE #-} Const ( Con ) +import {-# SOURCE #-} DataCon ( DataCon ) import Var ( Id, TyVar ) import CostCentre ( CostCentre ) @@ -33,7 +33,6 @@ import Outputable \begin{code} data PprEnv bndr = PE { - pCon :: Con -> SDoc, pSCC :: CostCentre -> SDoc, pTyVarO :: TyVar -> SDoc, -- to print tyvar occurrences @@ -53,8 +52,7 @@ data BindingSite = LambdaBind | CaseBind | LetBind \begin{code} initPprEnv - :: Maybe (Con -> SDoc) - -> Maybe (CostCentre -> SDoc) + :: Maybe (CostCentre -> SDoc) -> Maybe (TyVar -> SDoc) -> Maybe (Type -> SDoc) -> Maybe (BindingSite -> bndr -> SDoc) @@ -64,9 +62,8 @@ initPprEnv -- you can specify all the printers individually; if -- you don't specify one, you get bottom -initPprEnv p c tvo ty bndr occ - = PE (demaybe p) - (demaybe c) +initPprEnv c tvo ty bndr occ + = PE (demaybe c) (demaybe tvo) (demaybe ty) (demaybe bndr) diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 32774d9c6c..0db2b48901 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -12,7 +12,7 @@ module RdrName ( mkRdrUnqual, mkRdrQual, mkSrcUnqual, mkSrcQual, mkSysUnqual, mkSysQual, - mkPreludeQual, qualifyRdrName, + mkPreludeQual, qualifyRdrName, mkRdrNameWkr, dummyRdrVarName, dummyRdrTcName, -- Destruction @@ -26,7 +26,7 @@ import OccName ( NameSpace, tcName, OccName, mkSysOccFS, mkSrcOccFS, mkSrcVarOcc, - isDataOcc, isTvOcc + isDataOcc, isTvOcc, mkWorkerOcc ) import Module ( ModuleName, pprModuleName, mkSysModuleFS, mkSrcModuleFS @@ -97,6 +97,9 @@ mkPreludeQual sp mod n = RdrName (Qual mod) (mkSrcOccFS sp n) qualifyRdrName :: ModuleName -> RdrName -> RdrName -- Sets the module name of a RdrName, even if it has one already qualifyRdrName mod (RdrName _ occ) = RdrName (Qual mod) occ + +mkRdrNameWkr :: RdrName -> RdrName -- Worker-ify it +mkRdrNameWkr (RdrName qual occ) = RdrName qual (mkWorkerOcc occ) \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 6b5661b99e..3b7c61443e 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -30,6 +30,8 @@ module Unique ( initTyVarUnique, initTidyUniques, + isTupleKey, + -- now all the built-in Uniques (and functions to make them) -- [the Oh-So-Wonderful Haskell module system wins again...] mkAlphaTyVarUnique, @@ -235,6 +237,8 @@ getKey :: Unique -> Int# -- for Var incrUnique :: Unique -> Unique deriveUnique :: Unique -> Int -> Unique + +isTupleKey :: Unique -> Bool \end{code} @@ -429,9 +433,20 @@ mkPreludeTyConUnique i = mkUnique '3' i mkTupleTyConUnique a = mkUnique '4' a mkUbxTupleTyConUnique a = mkUnique '5' a -mkPreludeDataConUnique i = mkUnique '6' i -- must be alphabetic -mkTupleDataConUnique a = mkUnique '7' a -- ditto (*may* be used in C labels) -mkUbxTupleDataConUnique a = mkUnique '8' a +-- Data constructor keys occupy *two* slots. The first is used for the +-- data constructor itself and its wrapper function (the function that +-- evaluates arguments as necessary and calls the worker). The second is +-- used for the worker function (the function that builds the constructor +-- representation). + +mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic +mkTupleDataConUnique a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) +mkUbxTupleDataConUnique a = mkUnique '8' (2*a) + +-- This one is used for a tiresome reason +-- to improve a consistency-checking error check in the renamer +isTupleKey u = case unpkUnique u of + (tag,_) -> tag == '4' || tag == '5' || tag == '7' || tag == '8' mkPrimOpIdUnique op = mkUnique '9' op mkPreludeMiscIdUnique i = mkUnique '0' i @@ -557,24 +572,24 @@ threadIdPrimTyConKey = mkPreludeTyConUnique 70 %************************************************************************ \begin{code} -addrDataConKey = mkPreludeDataConUnique 1 -charDataConKey = mkPreludeDataConUnique 2 -consDataConKey = mkPreludeDataConUnique 3 -doubleDataConKey = mkPreludeDataConUnique 4 -falseDataConKey = mkPreludeDataConUnique 5 -floatDataConKey = mkPreludeDataConUnique 6 -intDataConKey = mkPreludeDataConUnique 7 -smallIntegerDataConKey = mkPreludeDataConUnique 12 -largeIntegerDataConKey = mkPreludeDataConUnique 13 -foreignObjDataConKey = mkPreludeDataConUnique 14 -nilDataConKey = mkPreludeDataConUnique 15 -ratioDataConKey = mkPreludeDataConUnique 16 -stablePtrDataConKey = mkPreludeDataConUnique 17 -stableNameDataConKey = mkPreludeDataConUnique 18 -trueDataConKey = mkPreludeDataConUnique 34 -wordDataConKey = mkPreludeDataConUnique 35 -stDataConKey = mkPreludeDataConUnique 40 -ioDataConKey = mkPreludeDataConUnique 42 +addrDataConKey = mkPreludeDataConUnique 0 +charDataConKey = mkPreludeDataConUnique 1 +consDataConKey = mkPreludeDataConUnique 2 +doubleDataConKey = mkPreludeDataConUnique 3 +falseDataConKey = mkPreludeDataConUnique 4 +floatDataConKey = mkPreludeDataConUnique 5 +intDataConKey = mkPreludeDataConUnique 6 +smallIntegerDataConKey = mkPreludeDataConUnique 7 +largeIntegerDataConKey = mkPreludeDataConUnique 8 +foreignObjDataConKey = mkPreludeDataConUnique 9 +nilDataConKey = mkPreludeDataConUnique 10 +ratioDataConKey = mkPreludeDataConUnique 11 +stablePtrDataConKey = mkPreludeDataConUnique 12 +stableNameDataConKey = mkPreludeDataConUnique 13 +trueDataConKey = mkPreludeDataConUnique 14 +wordDataConKey = mkPreludeDataConUnique 15 +stDataConKey = mkPreludeDataConUnique 16 +ioDataConKey = mkPreludeDataConUnique 17 \end{code} %************************************************************************ diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 489e42ab16..30b4affaf2 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -5,7 +5,7 @@ s% \begin{code} module Var ( - Var, IdOrTyVar, VarDetails, -- Abstract + Var, VarDetails, -- Abstract varName, varUnique, varInfo, varType, setVarName, setVarUnique, setVarType, setVarOcc, @@ -61,8 +61,6 @@ strictness). The essential info about different kinds of @Vars@ is in its @VarDetails@. \begin{code} -type IdOrTyVar = Var - data Var = Var { varName :: Name, diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs index a1036779f4..0cd670e3b5 100644 --- a/ghc/compiler/basicTypes/VarEnv.lhs +++ b/ghc/compiler/basicTypes/VarEnv.lhs @@ -31,11 +31,11 @@ module VarEnv ( import {-# SOURCE #-} CoreSyn( CoreExpr ) import {-# SOURCE #-} TypeRep( Type ) -import IdInfo ( OccInfo ) -import OccName ( TidyOccEnv, emptyTidyOccEnv ) -import Var ( Var, Id, IdOrTyVar ) -import UniqFM -import Util ( zipEqual ) +import BasicTypes ( OccInfo ) +import OccName ( TidyOccEnv, emptyTidyOccEnv ) +import Var ( Var, Id ) +import UniqFM +import Util ( zipEqual ) \end{code} @@ -49,7 +49,7 @@ When tidying up print names, we keep a mapping of in-scope occ-names (the TidyOccEnv) and a Var-to-Var of the current renamings. \begin{code} -type TidyEnv = (TidyOccEnv, VarEnv IdOrTyVar) +type TidyEnv = (TidyOccEnv, VarEnv Var) emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) \end{code} @@ -93,14 +93,14 @@ lookupSubstEnv (SE s _) v = lookupVarEnv s v extendSubstEnv :: SubstEnv -> Var -> SubstResult -> SubstEnv extendSubstEnv (SE s nt) v r = SE (extendVarEnv s v r) (noTys r nt) -mkSubstEnv :: [IdOrTyVar] -> [SubstResult] -> SubstEnv +mkSubstEnv :: [Var] -> [SubstResult] -> SubstEnv mkSubstEnv bs vs = extendSubstEnvList emptySubstEnv bs vs -extendSubstEnvList :: SubstEnv -> [IdOrTyVar] -> [SubstResult] -> SubstEnv +extendSubstEnvList :: SubstEnv -> [Var] -> [SubstResult] -> SubstEnv extendSubstEnvList env [] [] = env extendSubstEnvList (SE env nt) (b:bs) (r:rs) = extendSubstEnvList (SE (extendVarEnv env b r) (noTys r nt)) bs rs -delSubstEnv :: SubstEnv -> IdOrTyVar -> SubstEnv +delSubstEnv :: SubstEnv -> Var -> SubstEnv delSubstEnv (SE s nt) v = SE (delVarEnv s v) nt \end{code} diff --git a/ghc/compiler/basicTypes/VarSet.lhs b/ghc/compiler/basicTypes/VarSet.lhs index cf4f5df60e..faf1db1ab6 100644 --- a/ghc/compiler/basicTypes/VarSet.lhs +++ b/ghc/compiler/basicTypes/VarSet.lhs @@ -5,7 +5,7 @@ \begin{code} module VarSet ( - VarSet, IdSet, TyVarSet, IdOrTyVarSet, UVarSet, + VarSet, IdSet, TyVarSet, UVarSet, emptyVarSet, unitVarSet, mkVarSet, extendVarSet, elemVarSet, varSetElems, subVarSet, @@ -21,7 +21,7 @@ module VarSet ( #include "HsVersions.h" import CmdLineOpts ( opt_PprStyle_Debug ) -import Var ( Var, Id, TyVar, UVar, IdOrTyVar, setVarUnique ) +import Var ( Var, Id, TyVar, UVar, setVarUnique ) import Unique ( Unique, Uniquable(..), incrUnique, deriveUnique ) import UniqSet import UniqFM ( delFromUFM_Directly ) @@ -38,7 +38,6 @@ import Outputable type VarSet = UniqSet Var type IdSet = UniqSet Id type TyVarSet = UniqSet TyVar -type IdOrTyVarSet = UniqSet IdOrTyVar type UVarSet = UniqSet UVar emptyVarSet :: VarSet diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 8cda07b537..92acdfbdd8 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -33,24 +33,24 @@ import CgMonad import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp ) import CgStackery ( freeStackSlots, addFreeSlots ) -import CLabel ( mkStaticClosureLabel, mkClosureLabel, +import CLabel ( mkClosureLabel, mkBitmapLabel, pprCLabel ) import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo ) import BitSet ( mkBS, emptyBS ) import PrimRep ( isFollowableRep, getPrimRepSize ) import DataCon ( DataCon, dataConName ) -import Id ( Id, idPrimRep, idType ) +import Id ( Id, idPrimRep, idType, isDataConWrapId ) import Type ( typePrimRep ) import VarEnv import VarSet ( varSetElems ) -import Const ( Con(..), Literal ) +import Literal ( Literal ) import Maybes ( catMaybes, maybeToBool ) import Name ( isLocallyDefined, isWiredInName, NamedThing(..) ) #ifdef DEBUG import PprAbsC ( pprAmode ) #endif import PrimRep ( PrimRep(..) ) -import StgSyn ( StgArg, StgLiveVars, GenStgArg(..) ) +import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg ) import Unique ( Unique, Uniquable(..) ) import UniqSet ( elementOfUniqSet ) import Util ( zipWithEqual, sortLt ) @@ -252,8 +252,13 @@ I {\em think} all looking-up is done through @getCAddrMode(s)@. getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo) getCAddrModeAndInfo id - | not (isLocallyDefined name) || isWiredInName name - {- Why the "isWiredInName"? + | not (isLocallyDefined name) || isDataConWrapId id + -- Why the isDataConWrapId? Because CoreToStg changes a call to + -- a nullary constructor worker fn to a call to its wrapper, + -- which may not be defined until later + + {- -- OLD: the unpack stuff isn't injected now Jan 2000 + Why the "isWiredInName"? Imagine you are compiling PrelBase.hs (a module that supplies some of the wired-in values). What can happen is that the compiler will inject calls to @@ -342,6 +347,9 @@ getVolatileRegs vars getArgAmodes :: [StgArg] -> FCode [CAddrMode] getArgAmodes [] = returnFC [] getArgAmodes (atom:atoms) + | isStgTypeArg atom + = getArgAmodes atoms + | otherwise = getArgAmode atom `thenFC` \ amode -> getArgAmodes atoms `thenFC` \ amodes -> returnFC ( amode : amodes ) @@ -349,43 +357,7 @@ getArgAmodes (atom:atoms) getArgAmode :: StgArg -> FCode CAddrMode getArgAmode (StgVarArg var) = getCAddrMode var -- The common case - -getArgAmode (StgConArg (DataCon con)) - {- Why does this case differ from StgVarArg? - Because the program might look like this: - data Foo a = Empty | Baz a - f a x = let c = Empty! a - in h c - Now, when we go Core->Stg, we drop the type applications, - so we can inline c, giving - f x = h Empty - Now we are referring to Empty as an argument (rather than in an STGCon), - so we'll look it up with getCAddrMode. We want to return an amode for - the static closure that we make for nullary constructors. But if we blindly - go ahead with getCAddrMode we end up looking in the environment, and it ain't there! - - This special case used to be in getCAddrModeAndInfo, but it doesn't work there. - Consider: - f a x = Baz a x - If the constructor Baz isn't inlined we simply want to treat it like any other - identifier, with a top level definition. We don't want to spot that it's a constructor. - - In short - StgApp con args - and - StgCon con args - are treated differently; the former is a call to a bog standard function while the - latter uses the specially-labelled, pre-defined info tables etc for the constructor. - - The way to think of this case in getArgAmode is that - SApp f Empty - is really - App f (StgCon Empty []) - -} - = returnFC (CLbl (mkStaticClosureLabel (dataConName con)) PtrRep) - - -getArgAmode (StgConArg (Literal lit)) = returnFC (CLit lit) +getArgAmode (StgLitArg lit) = returnFC (CLit lit) \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index e358b9bf55..9ede65019e 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.37 2000/01/13 14:33:57 hwloidl Exp $ +% $Id: CgCase.lhs,v 1.38 2000/03/23 17:45:19 simonpj Exp $ % %******************************************************** %* * @@ -49,12 +49,11 @@ import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel, import ClosureInfo ( mkLFArgument ) import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) import CostCentre ( CostCentre ) -import CoreSyn ( isDeadBinder ) -import Id ( Id, idPrimRep ) +import Id ( Id, idPrimRep, isDeadBinder ) import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag, - isUnboxedTupleCon, dataConType ) + isUnboxedTupleCon ) import VarSet ( varSetElems ) -import Const ( Con(..), Literal ) +import Literal ( Literal ) import PrimOp ( primOpOutOfLine, PrimOp(..) ) import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) ) @@ -150,7 +149,7 @@ mkBuiltinUnique, because that occasionally clashes with some temporaries generated for _ccall_GC, amongst others (see CgExpr.lhs). \begin{code} -cgCase (StgCon (PrimOp op) args res_ty) +cgCase (StgPrimApp op args res_ty) live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt) | isEnumerationTyCon tycon = getArgAmodes args `thenFC` \ arg_amodes -> @@ -197,7 +196,7 @@ cgCase (StgCon (PrimOp op) args res_ty) Special case #2: inline PrimOps. \begin{code} -cgCase (StgCon (PrimOp op) args res_ty) +cgCase (StgPrimApp op args res_ty) live_in_whole_case live_in_alts bndr srt alts | not (primOpOutOfLine op) = diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 5fa258b359..f771fdb048 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -37,7 +37,7 @@ import Constants ( mAX_INTLIKE, mIN_INTLIKE, mIN_UPD_SIZE ) import CgHeapery ( allocDynClosure, inPlaceAllocDynClosure ) import CgTailCall ( performReturn, mkStaticAlgReturnCode, doTailCall, mkUnboxedTupleReturnCode ) -import CLabel ( mkClosureLabel, mkStaticClosureLabel ) +import CLabel ( mkClosureLabel ) import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument, layOutDynCon, layOutDynClosure, layOutStaticClosure, closureSize @@ -45,12 +45,12 @@ import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument, import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack, currentCCS ) import DataCon ( DataCon, dataConName, dataConTag, dataConTyCon, - isUnboxedTupleCon ) -import MkId ( mkDataConId ) + isUnboxedTupleCon, isNullaryDataCon, isDynDataCon, dataConId, dataConWrapId + ) import Id ( Id, idName, idType, idPrimRep ) import Name ( nameModule, isLocallyDefinedName ) import Module ( isDynamicModule ) -import Const ( Con(..), Literal(..), isLitLitLit ) +import Literal ( Literal(..) ) import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon ) import PrimRep ( PrimRep(..), isFollowableRep ) import Unique ( Uniquable(..) ) @@ -68,10 +68,9 @@ import Panic ( assertPanic, trace ) cgTopRhsCon :: Id -- Name of thing bound to this RHS -> DataCon -- Id -> [StgArg] -- Args - -> Bool -- All zero-size args (see buildDynCon) -> FCode (Id, CgIdInfo) -cgTopRhsCon id con args all_zero_size_args - = ASSERT(not (any_litlit_args || dynamic_con_or_args)) +cgTopRhsCon id con args + = ASSERT(not dynamic_con_or_args) -- checks for litlit args too ( -- LAY IT OUT getArgAmodes args `thenFC` \ amodes -> @@ -101,26 +100,7 @@ cgTopRhsCon id con args all_zero_size_args top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data -- stuff needed by the assert pred only. - any_litlit_args = any isLitLitArg args - dynamic_con_or_args = dynamic_con || any (isDynamic) args - - dynamic_con = isDynName (dataConName con) - - isDynName nm = - not (isLocallyDefinedName nm) && - isDynamicModule (nameModule nm) - - {- - Do any of the arguments refer to something in a DLL? - -} - isDynamic (StgVarArg v) = isDynName (idName v) - isDynamic (StgConArg c) = - case c of - DataCon dc -> isDynName (dataConName dc) - Literal l -> isLitLitLit l -- all bets are off if it is. - _ -> False - - + dynamic_con_or_args = isDynDataCon con || any isDynArg args \end{code} %************************************************************************ @@ -137,13 +117,17 @@ buildDynCon :: Id -- Name of the thing to which this constr will -- current CCS if currentOrSubsumedCCS -> DataCon -- The data constructor -> [CAddrMode] -- Its args - -> Bool -- True <=> all args (if any) are - -- of "zero size" (i.e., VoidRep); - -- The reason we don't just look at the - -- args is that we may be in a "knot", and - -- premature looking at the args will cause - -- the compiler to black-hole! -> FCode CgIdInfo -- Return details about how to find it + +-- We used to pass a boolean indicating whether all the +-- args were of size zero, so we could use a static +-- construtor; but I concluded that it just isn't worth it. +-- Now I/O uses unboxed tuples there just aren't any constructors +-- with all size-zero args. +-- +-- The reason for having a separate argument, rather than looking at +-- the addr modes of the args is that we may be in a "knot", and +-- premature looking at the args will cause the compiler to black-hole! \end{code} First we deal with the case of zero-arity constructors. Now, they @@ -155,9 +139,9 @@ which have exclusively size-zero (VoidRep) args, we generate no code at all. \begin{code} -buildDynCon binder cc con args all_zero_size_args@True +buildDynCon binder cc con [] = returnFC (stableAmodeIdInfo binder - (CLbl (mkStaticClosureLabel (dataConName con)) PtrRep) + (CLbl (mkClosureLabel (idName (dataConWrapId con))) PtrRep) (mkConLFInfo con)) \end{code} @@ -177,7 +161,7 @@ which is guaranteed in range. Because of this, we use can safely return an addressing mode. \begin{code} -buildDynCon binder cc con [arg_amode] all_zero_size_args@False +buildDynCon binder cc con [arg_amode] | maybeCharLikeCon con = absC (CAssign temp_amode (CCharLike arg_amode)) `thenC` @@ -188,8 +172,8 @@ buildDynCon binder cc con [arg_amode] all_zero_size_args@False where (temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con) - in_range_int_lit (CLit (MachInt val _)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE - in_range_int_lit other_amode = False + in_range_int_lit (CLit (MachInt val)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE + in_range_int_lit other_amode = False tycon = dataConTyCon con \end{code} @@ -197,7 +181,7 @@ buildDynCon binder cc con [arg_amode] all_zero_size_args@False Now the general case. \begin{code} -buildDynCon binder ccs con args all_zero_size_args@False +buildDynCon binder ccs con args = allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off -> returnFC (heapIdInfo binder hp_off lf_info) where @@ -283,9 +267,9 @@ bindUnboxedTupleComponents args Note: it's the responsibility of the @cgReturnDataCon@ caller to be sure the @amodes@ passed don't conflict with each other. \begin{code} -cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> Code +cgReturnDataCon :: DataCon -> [CAddrMode] -> Code -cgReturnDataCon con amodes all_zero_size_args +cgReturnDataCon con amodes = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_sp sequel) -> case sequel of @@ -315,7 +299,7 @@ cgReturnDataCon con amodes all_zero_size_args -- If the sequel is an update frame, we might be able to -- do update in place... UpdateCode - | not all_zero_size_args -- no nullary constructors, please + | not (isNullaryDataCon con) -- no nullary constructors, please && not (maybeCharLikeCon con) -- no chars please (these are all static) && not (any isFollowableRep (map getAmodeRep amodes)) -- no ptrs please (generational gc...) @@ -394,17 +378,14 @@ cgReturnDataCon con amodes all_zero_size_args -- This Id is also used to get a unique for a -- temporary variable, if the closure is a CHARLIKE. - -- funilly enough, this makes the unique always come + -- funnily enough, this makes the unique always come -- out as '54' :-) - buildDynCon (mkDataConId con) currentCCS - con amodes all_zero_size_args - `thenFC` \ idinfo -> - idInfoToAmode PtrRep idinfo `thenFC` \ amode -> + buildDynCon (dataConId con) currentCCS con amodes `thenFC` \ idinfo -> + idInfoToAmode PtrRep idinfo `thenFC` \ amode -> -- RETURN profCtrC SLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC` -- could use doTailCall here. performReturn (move_to_reg amode node) return - \end{code} diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 7ae92a890d..a20e0ee097 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -14,14 +14,13 @@ import CgMonad import StgSyn ( SRT(..) ) import AbsCUtils ( mkAbstractCs, mkAbsCStmts ) import CgTailCall ( performReturn, mkStaticAlgReturnCode ) -import CLabel ( mkConEntryLabel, mkStaticClosureLabel ) +import CLabel ( mkConEntryLabel ) import ClosureInfo ( layOutStaticClosure, layOutDynCon, mkConLFInfo, ClosureInfo ) import CostCentre ( dontCareCCS ) import FiniteMap ( fmToList, FiniteMap ) -import DataCon ( DataCon, dataConName, dataConAllRawArgTys ) -import Const ( Con(..) ) +import DataCon ( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon ) import Name ( getOccString ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon ) @@ -58,12 +57,9 @@ Static occurrences of the constructor macro: @STATIC_INFO_TABLE@. \end{description} -For zero-arity constructors, \tr{con}, we also generate a static closure: -\begin{description} -\item[@_closure@:] -A single static copy of the (zero-arity) constructor itself. -\end{description} +For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure; +it's place is taken by the top level defn of the constructor. For charlike and intlike closures there is a fixed array of static closures predeclared. @@ -115,8 +111,7 @@ genConInfo comp_info tycon data_con = mkAbstractCs [ CSplitMarker, closure_code, - static_code, - closure_maybe] + static_code] -- Order of things is to reduce forward references where (closure_info, body_code) = mkConCodeAndInfo data_con @@ -144,26 +139,15 @@ genConInfo comp_info tycon data_con cost_centre = mkCCostCentreStack dontCareCCS -- not worried about static data costs - -- For zero-arity data constructors, or, more accurately, - -- those which only have VoidRep args (or none): - -- We make the closure too (not just info tbl), so that we can share - -- one copy throughout. - closure_maybe = if not zero_arity_con then - AbsCNop - else - CStaticClosure closure_label -- Label for closure - static_ci -- Info table - cost_centre - [{-No args! A slight lie for constrs - with VoidRep args-}] - zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0 - zero_arity_con = all zero_size arg_tys + zero_arity_con = isNullaryDataCon data_con + -- We used to check that all the arg-sizes were zero, but we don't + -- really have any constructors with only zero-size args, and it's + -- just one more thing to go wrong. - arg_tys = dataConAllRawArgTys data_con + arg_tys = dataConRepArgTys data_con entry_label = mkConEntryLabel con_name - closure_label = mkStaticClosureLabel con_name con_name = dataConName data_con \end{code} @@ -173,7 +157,7 @@ mkConCodeAndInfo :: DataCon -- Data constructor mkConCodeAndInfo con = let - arg_tys = dataConAllRawArgTys con + arg_tys = dataConRepArgTys con (closure_info, arg_things) = layOutDynCon con typePrimRep arg_tys diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 0fca2d3e57..78e8a300d4 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.30 1999/10/25 13:21:16 sof Exp $ +% $Id: CgExpr.lhs,v 1.31 2000/03/23 17:45:19 simonpj Exp $ % %******************************************************** %* * @@ -40,9 +40,8 @@ import CostCentre ( sccAbleCostCentre, isSccCountCostCentre ) import Id ( idPrimRep, idType, Id ) import VarSet import DataCon ( DataCon, dataConTyCon ) -import Const ( Con(..) ) import IdInfo ( ArityInfo(..) ) -import PrimOp ( primOpOutOfLine, +import PrimOp ( primOpOutOfLine, ccallMayGC, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) ) import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep ) @@ -85,11 +84,9 @@ cgExpr (StgApp fun args) = cgTailCall fun args %******************************************************** \begin{code} -cgExpr (StgCon (DataCon con) args res_ty) +cgExpr (StgConApp con args) = getArgAmodes args `thenFC` \ amodes -> - cgReturnDataCon con amodes (all zero_size args) - where - zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 + cgReturnDataCon con amodes \end{code} Literals are similar to constructors; they return by putting @@ -97,9 +94,8 @@ themselves in an appropriate register and returning to the address on top of the stack. \begin{code} -cgExpr (StgCon (Literal lit) args res_ty) - = ASSERT( null args ) - performPrimReturn (text "literal" <+> ppr lit) (CLit lit) +cgExpr (StgLit lit) + = performPrimReturn (text "literal" <+> ppr lit) (CLit lit) \end{code} @@ -113,19 +109,21 @@ Here is where we insert real live machine instructions. NOTE about _ccall_GC_: -A _ccall_GC_ is treated as an out-of-line primop for the case -expression code, because we want a proper stack frame on the stack -when we perform it. When we get here, however, we need to actually -perform the call, so we treat it as an inline primop. +A _ccall_GC_ is treated as an out-of-line primop (returns True +for primOpOutOfLine) so that when we see the call in case context + case (ccall ...) of { ... } +we get a proper stack frame on the stack when we perform it. When we +get in a tail-call position, however, we need to actually perform the +call, so we treat it as an inline primop. \begin{code} -cgExpr (StgCon (PrimOp op@(CCallOp _ _ may_gc@True _)) args res_ty) +cgExpr (StgPrimApp op@(CCallOp ccall) args res_ty) = primRetUnboxedTuple op args res_ty -- tagToEnum# is special: we need to pull the constructor out of the table, -- and perform an appropriate return. -cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty) +cgExpr (StgPrimApp TagToEnumOp [arg] res_ty) = ASSERT(isEnumerationTyCon tycon) getArgAmode arg `thenFC` \amode -> -- save the tag in a temporary in case amode overlaps @@ -150,7 +148,7 @@ cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty) (Just (tycon,_)) = splitTyConApp_maybe res_ty -cgExpr x@(StgCon (PrimOp op) args res_ty) +cgExpr x@(StgPrimApp op args res_ty) | primOpOutOfLine op = tailCallPrimOp op args | otherwise = ASSERT(op /= SeqOp) -- can't handle SeqOp @@ -283,12 +281,9 @@ cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) -- the Id is passed along so a binding can be set up cgRhs name (StgRhsCon maybe_cc con args) - = getArgAmodes args `thenFC` \ amodes -> - buildDynCon name maybe_cc con amodes (all zero_size args) - `thenFC` \ idinfo -> + = getArgAmodes args `thenFC` \ amodes -> + buildDynCon name maybe_cc con amodes `thenFC` \ idinfo -> returnFC (name, idinfo) - where - zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body) = mkRhsClosure name cc bi srt fvs upd_flag args body @@ -445,7 +440,7 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder (StgRhsCon cc con args) = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec [] --No args; the binder is data structure, not a function - (StgCon (DataCon con) args (idType binder)) + (StgConApp con args) \end{code} Little helper for primitives that return unboxed tuples. @@ -478,5 +473,4 @@ primRetUnboxedTuple op args res_ty temp_amodes = zipWith CTemp temp_uniqs prim_reps in returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps [])) - \end{code} diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index d4784b6aae..a68a35287b 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP Project, Glasgow University, 1992-1998 % -% $Id: CgRetConv.lhs,v 1.19 1999/05/13 17:30:58 simonm Exp $ +% $Id: CgRetConv.lhs,v 1.20 2000/03/23 17:45:19 simonpj Exp $ % \section[CgRetConv]{Return conventions for the code generator} @@ -27,7 +27,7 @@ import CmdLineOpts ( opt_UseVanillaRegs, opt_UseFloatRegs, opt_UseDoubleRegs, opt_UseLongRegs ) import Maybes ( catMaybes ) -import DataCon ( dataConRawArgTys, DataCon ) +import DataCon ( DataCon ) import PrimOp ( PrimOp{-instance Outputable-} ) import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep ) import TyCon ( TyCon, tyConDataCons, tyConFamilySize ) diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 46e3b0219f..82c64a4c48 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.23 1999/11/02 15:05:43 simonmar Exp $ +% $Id: CgTailCall.lhs,v 1.24 2000/03/23 17:45:19 simonpj Exp $ % %******************************************************** %* * @@ -48,7 +48,7 @@ import ClosureInfo ( nodeMustPointToIt, import CmdLineOpts ( opt_DoSemiTagging ) import Id ( Id, idType, idName ) import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG ) -import Const ( mkMachInt ) +import Literal ( mkMachInt ) import Maybes ( assocMaybe, maybeToBool ) import PrimRep ( PrimRep(..) ) import StgSyn ( StgArg, GenStgArg(..) ) diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 157a6b70e2..62836a1d7b 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.39 1999/11/02 15:05:44 simonmar Exp $ +% $Id: ClosureInfo.lhs,v 1.40 2000/03/23 17:45:19 simonpj Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -67,7 +67,7 @@ import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject, import CgRetConv ( assignRegs ) import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, mkInfoTableLabel, - mkConInfoTableLabel, mkStaticClosureLabel, + mkConInfoTableLabel, mkCAFBlackHoleInfoTableLabel, mkSECAFBlackHoleInfoTableLabel, mkStaticInfoTableLabel, mkStaticConEntryLabel, @@ -79,7 +79,7 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_Parallel, opt_DoTickyProfiling, opt_SMP ) -import Id ( Id, idType, getIdArity ) +import Id ( Id, idType, idArityInfo ) import DataCon ( DataCon, dataConTag, fIRST_TAG, isNullaryDataCon, isTupleCon, dataConName ) @@ -258,7 +258,7 @@ mkLFLetNoEscape = LFLetNoEscape mkLFImported :: Id -> LambdaFormInfo mkLFImported id - = case getIdArity id of + = case idArityInfo id of ArityExactly 0 -> LFThunk (idType id) TopLevel True{-no fvs-} True{-updatable-} NonStandardThunk @@ -300,10 +300,8 @@ closurePtrsSize (MkClosureInfo _ _ sm_rep) -- not exported: sizes_from_SMRep :: SMRep -> (Int,Int) -sizes_from_SMRep (GenericRep ptrs nonptrs _) = (ptrs, nonptrs) -sizes_from_SMRep (StaticRep ptrs nonptrs _) = (ptrs, nonptrs) -sizes_from_SMRep ConstantRep = (0, 0) -sizes_from_SMRep BlackHoleRep = (0, 0) +sizes_from_SMRep (GenericRep _ ptrs nonptrs _) = (ptrs, nonptrs) +sizes_from_SMRep BlackHoleRep = (0, 0) \end{code} Computing slop size. WARNING: this looks dodgy --- it has deep @@ -341,16 +339,15 @@ slopSize cl_info@(MkClosureInfo _ lf_info sm_rep) computeSlopSize :: Int -> SMRep -> Bool -> Int -computeSlopSize tot_wds (StaticRep _ _ _) True -- Updatable +computeSlopSize tot_wds (GenericRep _ _ _ _) True -- Updatable = max 0 (mIN_UPD_SIZE - tot_wds) -computeSlopSize tot_wds (StaticRep _ _ _) False - = 0 -- non updatable, non-heap object -computeSlopSize tot_wds (GenericRep _ _ _) True -- Updatable - = max 0 (mIN_UPD_SIZE - tot_wds) -computeSlopSize tot_wds (GenericRep _ _ _) False - = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds) -computeSlopSize tot_wds ConstantRep _ - = 0 + +computeSlopSize tot_wds (GenericRep True _ _ _) False -- Non updatable + = 0 -- Static + +computeSlopSize tot_wds (GenericRep False _ _ _) False -- Non updatable + = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds) -- Dynamic + computeSlopSize tot_wds BlackHoleRep _ -- Updatable = max 0 (mIN_UPD_SIZE - tot_wds) \end{code} @@ -376,7 +373,7 @@ layOutDynClosure name kind_fn things lf_info where (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds, -- #ptr_wds - things_w_offsets) = mkVirtHeapOffsets sm_rep kind_fn things + things_w_offsets) = mkVirtHeapOffsets kind_fn things sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds \end{code} @@ -407,25 +404,26 @@ layOutStaticNoFVClosure. \begin{code} layOutStaticClosure name kind_fn things lf_info = (MkClosureInfo name lf_info - (StaticRep ptr_wds (tot_wds - ptr_wds) closure_type), + (GenericRep is_static ptr_wds (tot_wds - ptr_wds) closure_type), things_w_offsets) where (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds, -- #ptr_wds - things_w_offsets) = mkVirtHeapOffsets (StaticRep bot bot bot) kind_fn things + things_w_offsets) = mkVirtHeapOffsets kind_fn things -- constructors with no pointer fields will definitely be NOCAF things. -- this is a compromise until we can generate both kinds of constructor -- (a normal static kind and the NOCAF_STATIC kind). - closure_type = case lf_info of - LFCon _ _ | ptr_wds == 0 -> CONSTR_NOCAF - _ -> getStaticClosureType lf_info + closure_type = getClosureType is_static tot_wds ptr_wds lf_info + is_static = True bot = panic "layoutStaticClosure" layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> ClosureInfo layOutStaticNoFVClosure name lf_info - = MkClosureInfo name lf_info (StaticRep 0 0 (getStaticClosureType lf_info)) + = MkClosureInfo name lf_info (GenericRep is_static 0 0 (getClosureType is_static 0 0 lf_info)) + where + is_static = True \end{code} %************************************************************************ @@ -442,55 +440,45 @@ chooseDynSMRep chooseDynSMRep lf_info tot_wds ptr_wds = let - nonptr_wds = tot_wds - ptr_wds - closure_type = getClosureType tot_wds ptr_wds nonptr_wds lf_info + is_static = False + nonptr_wds = tot_wds - ptr_wds + closure_type = getClosureType is_static tot_wds ptr_wds lf_info in - case lf_info of - LFTuple _ True -> ConstantRep - LFCon _ True -> ConstantRep - _ -> GenericRep ptr_wds nonptr_wds closure_type - -getStaticClosureType :: LambdaFormInfo -> ClosureType -getStaticClosureType lf_info = - case lf_info of - LFCon con True -> CONSTR_NOCAF - LFCon con False -> CONSTR - LFReEntrant _ _ _ _ _ _ -> FUN - LFTuple _ _ -> CONSTR - LFThunk _ _ _ _ (SelectorThunk _) _ _ -> THUNK_SELECTOR - LFThunk _ _ _ True _ _ _ -> THUNK - LFThunk _ _ _ False _ _ _ -> FUN - _ -> panic "getClosureType" + GenericRep is_static ptr_wds nonptr_wds closure_type -- we *do* get non-updatable top-level thunks sometimes. eg. f = g -- gets compiled to a jump to g (if g has non-zero arity), instead of -- messing around with update frames and PAPs. We set the closure type -- to FUN_STATIC in this case. -getClosureType :: Int -> Int -> Int -> LambdaFormInfo -> ClosureType -getClosureType tot_wds ptrs nptrs lf_info = - case lf_info of - LFCon con True -> CONSTR_NOCAF +getClosureType :: Bool -> Int -> Int -> LambdaFormInfo -> ClosureType +getClosureType is_static tot_wds ptr_wds lf_info + = case lf_info of + LFCon con zero_arity + | is_static && ptr_wds == 0 -> CONSTR_NOCAF + | specialised_rep mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n + | otherwise -> CONSTR - LFCon con False - | tot_wds > 0 && tot_wds <= mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n ptrs nptrs - | otherwise -> CONSTR + LFTuple _ zero_arity + | is_static && ptr_wds == 0 -> CONSTR_NOCAF + | specialised_rep mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n + | otherwise -> CONSTR LFReEntrant _ _ _ _ _ _ - | tot_wds > 0 && tot_wds <= mAX_SPEC_FUN_SIZE -> FUN_p_n ptrs nptrs - | otherwise -> FUN - - LFTuple _ _ - | tot_wds > 0 && tot_wds <= mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n ptrs nptrs - | otherwise -> CONSTR + | specialised_rep mAX_SPEC_FUN_SIZE -> FUN_p_n + | otherwise -> FUN LFThunk _ _ _ _ (SelectorThunk _) _ _ -> THUNK_SELECTOR LFThunk _ _ _ _ _ _ _ - | tot_wds > 0 && tot_wds <= mAX_SPEC_THUNK_SIZE -> THUNK_p_n ptrs nptrs - | otherwise -> THUNK + | specialised_rep mAX_SPEC_THUNK_SIZE -> THUNK_p_n + | otherwise -> THUNK - _ -> panic "getClosureType" + _ -> panic "getClosureType" + where + specialised_rep max_size = not is_static + && tot_wds > 0 + && tot_wds <= max_size \end{code} %************************************************************************ @@ -504,8 +492,8 @@ smaller offsets than the unboxed things, and furthermore, the offsets in the result list \begin{code} -mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager - -> (a -> PrimRep) -- To be able to grab kinds; +mkVirtHeapOffsets :: + (a -> PrimRep) -- To be able to grab kinds; -- w/ a kind, we can find boxedness -> [a] -- Things to make offsets for -> (Int, -- *Total* number of words allocated @@ -516,7 +504,7 @@ mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager -- First in list gets lowest offset, which is initial offset + 1. -mkVirtHeapOffsets sm_rep kind_fun things +mkVirtHeapOffsets kind_fun things = let (ptrs, non_ptrs) = separateByPtrFollowness kind_fun things (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs @@ -712,7 +700,10 @@ blackHoleOnEntry :: ClosureInfo -> Bool -- Single-entry ones have no fvs to plug, and we trust they don't form part -- of a loop. -blackHoleOnEntry (MkClosureInfo _ _ (StaticRep _ _ _)) = False +blackHoleOnEntry (MkClosureInfo _ _ rep) + | isStaticRep rep + = False + -- Never black-hole a static closure blackHoleOnEntry (MkClosureInfo _ lf_info _) = case lf_info of @@ -969,25 +960,18 @@ infoTableLabelFromCI (MkClosureInfo id lf_info rep) mkConInfoPtr :: DataCon -> SMRep -> CLabel mkConInfoPtr con rep - = case rep of - StaticRep _ _ _ -> mkStaticInfoTableLabel name - _ -> mkConInfoTableLabel name + | isStaticRep rep = mkStaticInfoTableLabel name + | otherwise = mkConInfoTableLabel name where name = dataConName con mkConEntryPtr :: DataCon -> SMRep -> CLabel mkConEntryPtr con rep - = case rep of - StaticRep _ _ _ -> mkStaticConEntryLabel (dataConName con) - _ -> mkConEntryLabel (dataConName con) + | isStaticRep rep = mkStaticConEntryLabel (dataConName con) + | otherwise = mkConEntryLabel (dataConName con) where name = dataConName con -closureLabelFromCI (MkClosureInfo name _ rep) - | isConstantRep rep - = mkStaticClosureLabel name - -- This case catches those pesky static closures for nullary constructors - closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id entryLabelFromCI :: ClosureInfo -> CLabel diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index a2dcbc9bff..1f1d0f8e34 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -73,8 +73,11 @@ codeGen mod_name imported_modules cost_centre_info fe_binders cost_centre_info abstractC = mkAbstractCs [ init_stuff, - datatype_stuff, - code_stuff ] + code_stuff, + datatype_stuff] + -- Put datatype_stuff after code_stuff, because the + -- datatype closure table (for enumeration types) + -- to (say) PrelBase_True_closure, which is defined in code_stuff flat_abstractC = flattenAbsC fl_uniqs abstractC in @@ -221,9 +224,7 @@ cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) -- the Id is passed along for setting up a binding... cgTopRhs bndr (StgRhsCon cc con args) - = forkStatics (cgTopRhsCon bndr con args (all zero_size args)) - where - zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 + = forkStatics (cgTopRhsCon bndr con args) cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body) = ASSERT(null fvs) -- There should be no free variables diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs index aabcf40449..c338cf8b3f 100644 --- a/ghc/compiler/codeGen/SMRep.lhs +++ b/ghc/compiler/codeGen/SMRep.lhs @@ -9,7 +9,7 @@ Other modules should access this info through ClosureInfo. \begin{code} module SMRep ( SMRep(..), ClosureType(..), - isConstantRep, isStaticRep, + isStaticRep, fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize, fixedItblSize, pprSMRep @@ -68,31 +68,28 @@ import GlaExts ( Int(..), Int#, (<#), (==#), (<#), (>#) ) \begin{code} data SMRep -- static closure have an extra static link field at the end. - = StaticRep - Int -- # ptr words (useful for interpreter, debugger, etc) - Int -- # non-ptr words - ClosureType -- closure type - - | GenericRep -- GC routines consult sizes in info tbl + = GenericRep -- GC routines consult sizes in info tbl + Bool -- True <=> This is a static closure. Affects how + -- we garbage-collect it Int -- # ptr words Int -- # non-ptr words ClosureType -- closure type - | ConstantRep -- CONSTR with zero-arity - | BlackHoleRep -data ClosureType +data ClosureType -- Corresponds 1-1 with the varieties of closures + -- implemented by the RTS. Compare with ghc/includes/ClosureTypes.h = CONSTR - | CONSTR_p_n Int Int + | CONSTR_p_n -- The p_n variants have more efficient GC, but we + -- only provide them for dynamically-allocated closures + -- (We could do them for static ones, but we don't) | CONSTR_NOCAF | FUN - | FUN_p_n Int Int + | FUN_p_n | THUNK - | THUNK_p_n Int Int + | THUNK_p_n | THUNK_SELECTOR deriving (Eq,Ord) - \end{code} Size of a closure header. @@ -140,77 +137,63 @@ tickyItblSize | opt_DoTickyProfiling = tICKY_ITBL_SIZE \end{code} \begin{code} -isConstantRep, isStaticRep :: SMRep -> Bool -isConstantRep ConstantRep = True -isConstantRep other = False - -isStaticRep (StaticRep _ _ _) = True -isStaticRep _ = False +isStaticRep :: SMRep -> Bool +isStaticRep (GenericRep is_static _ _ _) = is_static +isStaticRep BlackHoleRep = False \end{code} \begin{code} -{- ToDo: needed? -} -instance Text SMRep where - showsPrec d rep - = showString (case rep of - StaticRep _ _ _ -> "STATIC" - GenericRep _ _ _ -> "" - ConstantRep -> "") - instance Outputable SMRep where ppr rep = pprSMRep rep pprSMRep :: SMRep -> SDoc -pprSMRep (GenericRep _ _ t) = pprClosureType t -pprSMRep (StaticRep _ _ t) = pprClosureType t <> ptext SLIT("_STATIC") -pprSMRep ConstantRep = ptext SLIT("CONSTR_NOCAF_STATIC") -pprSMRep BlackHoleRep = ptext SLIT("BLACKHOLE") - -pprClosureType CONSTR = ptext SLIT("CONSTR") -pprClosureType (CONSTR_p_n p n) = ptext SLIT("CONSTR_") <> int p <> char '_' <> int n -pprClosureType CONSTR_NOCAF = ptext SLIT("CONSTR_NOCAF") -pprClosureType FUN = ptext SLIT("FUN") -pprClosureType (FUN_p_n p n) = ptext SLIT("FUN_") <> int p <> char '_' <> int n -pprClosureType THUNK = ptext SLIT("THUNK") -pprClosureType (THUNK_p_n p n) = ptext SLIT("THUNK_") <> int p <> char '_' <> int n -pprClosureType THUNK_SELECTOR = ptext SLIT("THUNK_SELECTOR") +pprSMRep (GenericRep True ptrs nptrs clo_ty) = pprClosureType clo_ty ptrs nptrs <> ptext SLIT("_STATIC") +pprSMRep (GenericRep False ptrs nptrs clo_ty) = pprClosureType clo_ty ptrs nptrs + +pprClosureType CONSTR p n = ptext SLIT("CONSTR") +pprClosureType CONSTR_p_n p n = ptext SLIT("CONSTR_") <> int p <> char '_' <> int n +pprClosureType CONSTR_NOCAF p n = ptext SLIT("CONSTR_NOCAF") +pprClosureType FUN p n = ptext SLIT("FUN") +pprClosureType FUN_p_n p n = ptext SLIT("FUN_") <> int p <> char '_' <> int n +pprClosureType THUNK p n = ptext SLIT("THUNK") +pprClosureType THUNK_p_n p n = ptext SLIT("THUNK_") <> int p <> char '_' <> int n +pprClosureType THUNK_SELECTOR p n = ptext SLIT("THUNK_SELECTOR") #ifndef OMIT_NATIVE_CODEGEN getSMRepClosureTypeInt :: SMRep -> Int -getSMRepClosureTypeInt (GenericRep _ _ t) = - case t of - CONSTR -> cONSTR - CONSTR_p_n 1 0 -> cONSTR_1_0 - CONSTR_p_n 0 1 -> cONSTR_0_1 - CONSTR_p_n 2 0 -> cONSTR_2_0 - CONSTR_p_n 1 1 -> cONSTR_1_1 - CONSTR_p_n 0 2 -> cONSTR_0_2 - CONSTR_NOCAF -> panic "getClosureTypeInt: CONSTR_NOCAF" - FUN -> fUN - FUN_p_n 1 0 -> fUN_1_0 - FUN_p_n 0 1 -> fUN_0_1 - FUN_p_n 2 0 -> fUN_2_0 - FUN_p_n 1 1 -> fUN_1_1 - FUN_p_n 0 2 -> fUN_0_2 - THUNK -> tHUNK - THUNK_p_n 1 0 -> tHUNK_1_0 - THUNK_p_n 0 1 -> tHUNK_0_1 - THUNK_p_n 2 0 -> tHUNK_2_0 - THUNK_p_n 1 1 -> tHUNK_1_1 - THUNK_p_n 0 2 -> tHUNK_0_2 - THUNK_SELECTOR -> tHUNK_SELECTOR -getSMRepClosureTypeInt (StaticRep _ _ t) = - case t of - CONSTR -> cONSTR_STATIC - CONSTR_NOCAF -> cONSTR_NOCAF_STATIC - FUN -> fUN_STATIC - THUNK -> tHUNK_STATIC - THUNK_SELECTOR -> panic "getClosureTypeInt: THUNK_SELECTOR_STATIC" - -getSMRepClosureTypeInt ConstantRep = cONSTR_NOCAF_STATIC +getSMRepClosureTypeInt (GenericRep False _ _ CONSTR) = cONSTR +getSMRepClosureTypeInt (GenericRep False 1 0 CONSTR_p_n) = cONSTR_1_0 +getSMRepClosureTypeInt (GenericRep False 0 1 CONSTR_p_n) = cONSTR_0_1 +getSMRepClosureTypeInt (GenericRep False 2 0 CONSTR_p_n) = cONSTR_2_0 +getSMRepClosureTypeInt (GenericRep False 1 1 CONSTR_p_n) = cONSTR_1_1 +getSMRepClosureTypeInt (GenericRep False 0 2 CONSTR_p_n) = cONSTR_0_2 + +getSMRepClosureTypeInt (GenericRep False _ _ FUN) = fUN +getSMRepClosureTypeInt (GenericRep False 1 0 FUN_p_n) = fUN_1_0 +getSMRepClosureTypeInt (GenericRep False 0 1 FUN_p_n) = fUN_0_1 +getSMRepClosureTypeInt (GenericRep False 2 0 FUN_p_n) = fUN_2_0 +getSMRepClosureTypeInt (GenericRep False 1 1 FUN_p_n) = fUN_1_1 +getSMRepClosureTypeInt (GenericRep False 0 2 FUN_p_n) = fUN_0_2 + +getSMRepClosureTypeInt (GenericRep False _ _ THUNK) = tHUNK +getSMRepClosureTypeInt (GenericRep False 1 0 THUNK_p_n) = tHUNK_1_0 +getSMRepClosureTypeInt (GenericRep False 0 1 THUNK_p_n) = tHUNK_0_1 +getSMRepClosureTypeInt (GenericRep False 2 0 THUNK_p_n) = tHUNK_2_0 +getSMRepClosureTypeInt (GenericRep False 1 1 THUNK_p_n) = tHUNK_1_1 +getSMRepClosureTypeInt (GenericRep False 0 2 THUNK_p_n) = tHUNK_0_2 + +getSMRepClosureTypeInt (GenericRep False _ _ THUNK_SELECTOR) = tHUNK_SELECTOR + +getSMRepClosureTypeInt (GenericRep True _ _ CONSTR) = cONSTR_STATIC +getSMRepClosureTypeInt (GenericRep True _ _ CONSTR_NOCAF) = cONSTR_NOCAF_STATIC +getSMRepClosureTypeInt (GenericRep True _ _ FUN) = fUN_STATIC +getSMRepClosureTypeInt (GenericRep True _ _ THUNK) = tHUNK_STATIC getSMRepClosureTypeInt BlackHoleRep = bLACKHOLE +getSMRepClosureTypeInt rep = pprPanic "getSMRepClosureTypeInt:" (pprSMRep rep) + + -- Just the ones we need: #include "../includes/ClosureTypes.h" diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index a6f39b37b0..3c4d5c87c9 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -15,9 +15,9 @@ module CoreFVs ( #include "HsVersions.h" import CoreSyn -import Id ( Id, idFreeTyVars, getIdSpecialisation ) +import Id ( Id, idFreeTyVars, idSpecialisation ) import VarSet -import Var ( IdOrTyVar, isId ) +import Var ( Var, isId ) import Name ( isLocallyDefined ) import Type ( tyVarsOfType, Type ) import Util ( mapAndUnzip ) @@ -38,30 +38,30 @@ So far as type variables are concerned, it only finds tyvars that are but not those that are free in the type of variable occurrence. \begin{code} -exprFreeVars :: CoreExpr -> IdOrTyVarSet -- Find all locally-defined free Ids or tyvars +exprFreeVars :: CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars exprFreeVars = exprSomeFreeVars isLocallyDefined -exprsFreeVars :: [CoreExpr] -> IdOrTyVarSet +exprsFreeVars :: [CoreExpr] -> VarSet exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting -> CoreExpr - -> IdOrTyVarSet + -> VarSet exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting -> [CoreExpr] - -> IdOrTyVarSet + -> VarSet exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet -type InterestingVarFun = IdOrTyVar -> Bool -- True <=> interesting +type InterestingVarFun = Var -> Bool -- True <=> interesting \end{code} \begin{code} type FV = InterestingVarFun - -> IdOrTyVarSet -- In scope - -> IdOrTyVarSet -- Free vars + -> VarSet -- In scope + -> VarSet -- Free vars union :: FV -> FV -> FV union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope @@ -75,7 +75,7 @@ noVars fv_cand in_scope = emptyVarSet -- is a little weird. The reason is that the former is more efficient, -- but the latter is more fine grained, and a makes a difference when -- a variable mentions itself one of its own rule RHSs -oneVar :: IdOrTyVar -> FV +oneVar :: Var -> FV oneVar var fv_cand in_scope = foldVarSet add_rule_var var_itself_set (idRuleVars var) where @@ -84,7 +84,7 @@ oneVar var fv_cand in_scope add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var | otherwise = set -someVars :: IdOrTyVarSet -> FV +someVars :: VarSet -> FV someVars vars fv_cand in_scope = filterVarSet (keep_it fv_cand in_scope) vars @@ -111,7 +111,7 @@ expr_fvs :: CoreExpr -> FV expr_fvs (Type ty) = someVars (tyVarsOfType ty) expr_fvs (Var var) = oneVar var -expr_fvs (Con con args) = foldr (union . expr_fvs) noVars args +expr_fvs (Lit lit) = noVars expr_fvs (Note _ expr) = expr_fvs expr expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) @@ -133,17 +133,17 @@ expr_fvs (Let (Rec pairs) body) \begin{code} -idRuleVars ::Id -> IdOrTyVarSet -idRuleVars id = rulesRhsFreeVars (getIdSpecialisation id) +idRuleVars ::Id -> VarSet +idRuleVars id = rulesRhsFreeVars (idSpecialisation id) -idFreeVars :: Id -> IdOrTyVarSet +idFreeVars :: Id -> VarSet idFreeVars id = idRuleVars id `unionVarSet` idFreeTyVars id -rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> IdOrTyVarSet +rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet rulesSomeFreeVars interesting (Rules rules _) = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules -ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet +ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet ruleSomeFreeVars interesting (BuiltinRule _) = noFVs ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs) = rule_fvs interesting emptyVarSet @@ -151,7 +151,7 @@ ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs) rule_fvs = addBndrs tpl_vars $ foldr (union . expr_fvs) (expr_fvs rhs) tpl_args -ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet +ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> VarSet ruleSomeLhsFreeVars fn (BuiltinRule _) = noFVs ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs) = foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars @@ -168,8 +168,8 @@ The free variable pass annotates every node in the expression with its NON-GLOBAL free variables and type variables. \begin{code} -type CoreBindWithFVs = AnnBind Id IdOrTyVarSet -type CoreExprWithFVs = AnnExpr Id IdOrTyVarSet +type CoreBindWithFVs = AnnBind Id VarSet +type CoreExprWithFVs = AnnExpr Id VarSet -- Every node annotated with its free variables, -- both Ids and TyVars @@ -180,7 +180,7 @@ noFVs = emptyVarSet aFreeVar = unitVarSet unionFVs = unionVarSet -filters :: IdOrTyVar -> IdOrTyVarSet -> IdOrTyVarSet +filters :: Var -> VarSet -> VarSet -- (b `filters` s) removes the binder b from the free variable set s, -- but *adds* to s @@ -235,11 +235,7 @@ freeVars (Var v) fvs | isLocallyDefined v = aFreeVar v | otherwise = noFVs -freeVars (Con con args) - = (foldr (unionFVs . freeVarsOf) noFVs args2, AnnCon con args2) - where - args2 = map freeVars args - +freeVars (Lit lit) = (noFVs, AnnLit lit) freeVars (Lam b body) = (b `filters` freeVarsOf body', AnnLam b body') where diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index b3de053517..7881f4a6ac 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -12,7 +12,7 @@ module CoreLint ( #include "HsVersions.h" -import IO ( hPutStr, hPutStrLn, stderr ) +import IO ( hPutStr, hPutStrLn, stderr, stdout ) import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug ) import CoreSyn @@ -20,9 +20,10 @@ import CoreFVs ( idFreeVars ) import CoreUtils ( exprOkForSpeculation ) import Bag -import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt ) -import Id ( mayHaveNoBinding ) -import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar, isId ) +import Literal ( Literal, literalType ) +import DataCon ( DataCon, dataConRepType ) +import Id ( mayHaveNoBinding, isDeadBinder ) +import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId ) import VarSet import Subst ( mkTyVarSubst, substTy ) import Name ( isLocallyDefined, getSrcLoc ) @@ -71,7 +72,7 @@ endPass pass_name dump_flag binds -- Report result size if required -- This has the side effect of forcing the intermediate to be evaluated if opt_D_show_passes then - hPutStrLn stderr (" Result size = " ++ show (coreBindsSize binds)) + hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds)) else return () @@ -162,7 +163,7 @@ We use this to check all unfoldings that come in from interfaces \begin{code} lintUnfolding :: SrcLoc - -> [IdOrTyVar] -- Treat these as in scope + -> [Var] -- Treat these as in scope -> CoreExpr -> Maybe Message -- Nothing => OK @@ -220,6 +221,7 @@ lintSingleBinding rec_flag (binder,rhs) lintCoreExpr :: CoreExpr -> LintM Type lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var) +lintCoreExpr (Lit lit) = returnL (literalType lit) lintCoreExpr (Note (Coerce to_ty from_ty) expr) = lintCoreExpr expr `thenL` \ expr_ty -> @@ -243,11 +245,6 @@ lintCoreExpr (Let (Rec pairs) body) where bndrs = map fst pairs -lintCoreExpr e@(Con con args) - = addLoc (AnExpr e) $ - checkL (conOkForApp con) (mkConAppMsg e) `seqL` - lintCoreArgs (conType con) args - lintCoreExpr e@(App fun arg) = lintCoreExpr fun `thenL` \ ty -> addLoc (AnExpr e) $ @@ -410,10 +407,16 @@ lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs) = checkL (null args) (mkDefaultArgsMsg args) `seqL` lintCoreExpr rhs -lintCoreAlt scrut_ty alt@(con, args, rhs) - = addLoc (CaseAlt alt) ( +lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs) + = checkL (null args) (mkDefaultArgsMsg args) `seqL` + checkTys lit_ty scrut_ty + (mkBadPatMsg lit_ty scrut_ty) `seqL` + lintCoreExpr rhs + where + lit_ty = literalType lit - checkL (conOkForAlt con) (mkConAltMsg con) `seqL` +lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs) + = addLoc (CaseAlt alt) ( mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg))) (mkUnboxedTupleMsg arg)) args `seqL` @@ -425,8 +428,8 @@ lintCoreAlt scrut_ty alt@(con, args, rhs) -- This code is remarkably compact considering what it does! -- NB: args must be in scope here so that the lintCoreArgs line works. case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) -> - lintTyApps (conType con) tycon_arg_tys `thenL` \ con_type -> - lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty -> + lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type -> + lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty -> checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) } `seqL` @@ -445,7 +448,7 @@ lintCoreAlt scrut_ty alt@(con, args, rhs) %************************************************************************ \begin{code} -lintBinder :: IdOrTyVar -> LintM () +lintBinder :: Var -> LintM () lintBinder v = nopL -- ToDo: lint its type @@ -539,24 +542,24 @@ addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m loc scope errs = m (extra_loc:loc) scope errs -addInScopeVars :: [IdOrTyVar] -> LintM a -> LintM a +addInScopeVars :: [Var] -> LintM a -> LintM a addInScopeVars ids m loc scope errs = m loc (scope `unionVarSet` mkVarSet ids) errs \end{code} \begin{code} -checkIdInScope :: IdOrTyVar -> LintM () +checkIdInScope :: Var -> LintM () checkIdInScope id = checkInScope (ptext SLIT("is out of scope")) id -checkBndrIdInScope :: IdOrTyVar -> IdOrTyVar -> LintM () +checkBndrIdInScope :: Var -> Var -> LintM () checkBndrIdInScope binder id = checkInScope msg id where msg = ptext SLIT("is out of scope inside info for") <+> ppr binder -checkInScope :: SDoc -> IdOrTyVar -> LintM () +checkInScope :: SDoc -> Var -> LintM () checkInScope loc_msg var loc scope errs | isLocallyDefined var && not (var `elemVarSet` scope) @@ -618,21 +621,12 @@ pp_binder b = hsep [ppr b, dcolon, ppr (idType b)] ------------------------------------------------------ -- Messages for case expressions -mkConAppMsg :: CoreExpr -> Message -mkConAppMsg e - = hang (text "Application of newtype constructor:") - 4 (ppr e) - -mkConAltMsg :: Con -> Message -mkConAltMsg con - = text "PrimOp in case pattern:" <+> ppr con - mkNullAltsMsg :: CoreExpr -> Message mkNullAltsMsg e = hang (text "Case expression with no alternatives:") 4 (ppr e) -mkDefaultArgsMsg :: [IdOrTyVar] -> Message +mkDefaultArgsMsg :: [Var] -> Message mkDefaultArgsMsg args = hang (text "DEFAULT case with binders") 4 (ppr args) @@ -669,7 +663,6 @@ mkBadPatMsg con_result_ty scrut_ty ------------------------------------------------------ -- Other error messages -mkAppMsg :: Type -> Type -> Message mkAppMsg fun arg = vcat [ptext SLIT("Argument value doesn't match argument type:"), hang (ptext SLIT("Fun type:")) 4 (ppr fun), diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot b/ghc/compiler/coreSyn/CoreSyn.hi-boot index a400c37d79..5002208fec 100644 --- a/ghc/compiler/coreSyn/CoreSyn.hi-boot +++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot @@ -4,11 +4,11 @@ CoreSyn CoreExpr CoreRule CoreRules emptyCoreRules isEmptyCoreRules seqRules ; _declarations_ -- Needed by IdInfo -1 type CoreExpr = Expr Var.IdOrTyVar; +1 type CoreExpr = Expr Var.Var; 1 data Expr b ; 1 data CoreRule ; -1 data CoreRules = Rules [CoreRule] VarSet.IdOrTyVarSet ; +1 data CoreRules = Rules [CoreRule] VarSet.VarSet ; 1 emptyCoreRules _:_ CoreRules ;; 1 seqRules _:_ CoreRules -> PrelBase.() ;; 1 isEmptyCoreRules _:_ CoreRules -> PrelBase.Bool ;; diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 b/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 index 2ddc75bb32..49830e8d1d 100644 --- a/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 +++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 @@ -2,11 +2,11 @@ __interface CoreSyn 1 0 where __export CoreSyn CoreExpr CoreRules CoreRule emptyCoreRules isEmptyCoreRules seqRules ; -- Needed by IdInfo -1 type CoreExpr = Expr Var.IdOrTyVar; +1 type CoreExpr = Expr Var.Var; 1 data Expr b ; 1 data CoreRule ; -1 data CoreRules = Rules [CoreRule] VarSet.IdOrTyVarSet ; +1 data CoreRules = Rules [CoreRule] VarSet.VarSet ; 1 emptyCoreRules :: CoreRules ; 1 seqRules :: CoreRules -> PrelBase.Z0T ; 1 isEmptyCoreRules :: CoreRules -> PrelBase.Bool ; diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 80937db165..526fee5b82 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -5,16 +5,18 @@ \begin{code} module CoreSyn ( - Expr(..), Alt, Bind(..), Arg(..), Note(..), + Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..), CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, - mkLets, mkLams, + mkLets, mkLams, mkApps, mkTyApps, mkValApps, mkVarApps, - mkLit, mkStringLit, mkStringLitFS, mkConApp, mkPrimApp, mkNote, + mkLit, mkIntLitInt, mkIntLit, + mkStringLit, mkStringLitFS, mkConApp, + mkAltExpr, bindNonRec, mkIfThenElse, varToCoreExpr, - bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId, + bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isTyVar, isId, collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, collectArgs, collectBindersIgnoringNotes, coreExprCc, @@ -29,7 +31,7 @@ module CoreSyn ( coreBindsSize, -- Annotated expressions - AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, deAnnotate', -- Core rules CoreRules(..), -- Representation needed by friends @@ -41,13 +43,15 @@ module CoreSyn ( #include "HsVersions.h" import TysWiredIn ( boolTy, stringTy, nilDataCon ) -import CostCentre ( CostCentre, isDupdCC, noCostCentre ) -import Var ( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType ) +import CostCentre ( CostCentre, noCostCentre ) +import Var ( Var, Id, TyVar, isTyVar, isId, idType ) import VarEnv -import Id ( mkWildId, getIdOccInfo, idInfo ) +import Id ( mkWildId, idOccInfo, idInfo ) import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType ) import IdInfo ( OccInfo(..), megaSeqIdInfo ) -import Const ( Con(..), DataCon, Literal(MachStr), mkMachInt, PrimOp ) +import Literal ( Literal(MachStr), mkMachInt ) +import PrimOp ( PrimOp ) +import DataCon ( DataCon, dataConId ) import TysWiredIn ( trueDataCon, falseDataCon ) import ThinAir ( unpackCStringId, unpackCString2Id, addr2IntegerId ) import VarSet @@ -67,9 +71,7 @@ infixl 8 `App` -- App brackets to the left data Expr b -- "b" for the type of binders, = Var Id - | Con Con [Arg b] -- Guaranteed saturated - -- The Con can be a DataCon, Literal, PrimOP - -- but cannot be DEFAULT + | Lit Literal | App (Expr b) (Arg b) | Lam b (Expr b) | Let (Bind b) (Expr b) @@ -81,9 +83,12 @@ data Expr b -- "b" for the type of binders, type Arg b = Expr b -- Can be a Type -type Alt b = (Con, [b], Expr b) - -- (DEFAULT, [], rhs) is the default alternative - -- The Con can be a Literal, DataCon, or DEFAULT, but cannot be PrimOp +type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative + +data AltCon = DataAlt DataCon + | LitAlt Literal + | DEFAULT + deriving (Eq, Ord) data Bind b = NonRec b (Expr b) | Rec [(b, (Expr b))] @@ -118,7 +123,7 @@ but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. \begin{code} data CoreRules = Rules [CoreRule] - IdOrTyVarSet -- Locally-defined free vars of RHSs + VarSet -- Locally-defined free vars of RHSs type RuleName = FAST_STRING @@ -138,7 +143,7 @@ emptyCoreRules = Rules [] emptyVarSet isEmptyCoreRules :: CoreRules -> Bool isEmptyCoreRules (Rules rs _) = null rs -rulesRhsFreeVars :: CoreRules -> IdOrTyVarSet +rulesRhsFreeVars :: CoreRules -> VarSet rulesRhsFreeVars (Rules _ fvs) = fvs rulesRules :: CoreRules -> [CoreRule] @@ -148,6 +153,28 @@ rulesRules (Rules rules _) = rules %************************************************************************ %* * +\subsection{The main data type} +%* * +%************************************************************************ + +\begin{code} +-- The Ord is needed for the FiniteMap used in the lookForConstructor +-- in SimplEnv. If you declared that lookForConstructor *ignores* +-- constructor-applications with LitArg args, then you could get +-- rid of this Ord. + +instance Outputable AltCon where + ppr (DataAlt dc) = ppr dc + ppr (LitAlt lit) = ppr lit + ppr DEFAULT = ptext SLIT("__DEFAULT") + +instance Show AltCon where + showsPrec p con = showsPrecSDoc p (ppr con) +\end{code} + + +%************************************************************************ +%* * \subsection{Useful synonyms} %* * %************************************************************************ @@ -155,7 +182,7 @@ rulesRules (Rules rules _) = rules The common case \begin{code} -type CoreBndr = IdOrTyVar +type CoreBndr = Var type CoreExpr = Expr CoreBndr type CoreArg = Arg CoreBndr type CoreBind = Bind CoreBndr @@ -185,7 +212,7 @@ type TaggedAlt t = Alt (Tagged t) mkApps :: Expr b -> [Arg b] -> Expr b mkTyApps :: Expr b -> [Type] -> Expr b mkValApps :: Expr b -> [Expr b] -> Expr b -mkVarApps :: CoreExpr -> [IdOrTyVar] -> CoreExpr +mkVarApps :: Expr b -> [Var] -> Expr b mkApps f args = foldl App f args mkTyApps f args = foldl (\ e a -> App e (Type a)) f args @@ -193,14 +220,17 @@ mkValApps f args = foldl (\ e a -> App e a) f args mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars mkLit :: Literal -> Expr b -mkStringLit :: String -> Expr b -mkStringLitFS :: FAST_STRING -> Expr b +mkIntLit :: Integer -> Expr b +mkIntLitInt :: Int -> Expr b +mkStringLit :: String -> Expr b -- Makes a [Char] literal +mkStringLitFS :: FAST_STRING -> Expr b -- Makes a [Char] literal mkConApp :: DataCon -> [Arg b] -> Expr b -mkPrimApp :: PrimOp -> [Arg b] -> Expr b -mkLit lit = Con (Literal lit) [] -mkConApp con args = Con (DataCon con) args -mkPrimApp op args = Con (PrimOp op) args +mkLit lit = Lit lit +mkConApp con args = mkApps (Var (dataConId con)) args + +mkIntLit n = Lit (mkMachInt n) +mkIntLitInt n = Lit (mkMachInt (toInteger n)) mkStringLit str = mkStringLitFS (_PK_ str) @@ -208,17 +238,17 @@ mkStringLitFS str | any is_NUL (_UNPK_ str) = -- Must cater for NULs in literal string mkApps (Var unpackCString2Id) - [mkLit (MachStr str), - mkLit (mkMachInt (toInteger (_LENGTH_ str)))] + [Lit (MachStr str), + mkIntLitInt (_LENGTH_ str)] | otherwise = -- No NULs in the string - App (Var unpackCStringId) (mkLit (MachStr str)) + App (Var unpackCStringId) (Lit (MachStr str)) where is_NUL c = c == '\0' -varToCoreExpr :: CoreBndr -> CoreExpr +varToCoreExpr :: CoreBndr -> Expr b varToCoreExpr v | isId v = Var v | otherwise = Type (mkTyVarTy v) \end{code} @@ -249,38 +279,22 @@ bindNonRec bndr rhs body mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr mkIfThenElse guard then_expr else_expr = Case guard (mkWildId boolTy) - [ (DataCon trueDataCon, [], then_expr), - (DataCon falseDataCon, [], else_expr) ] + [ (DataAlt trueDataCon, [], then_expr), + (DataAlt falseDataCon, [], else_expr) ] \end{code} -mkNote removes redundant coercions, and SCCs where possible \begin{code} -mkNote :: Note -> Expr b -> Expr b -mkNote (Coerce to_ty1 from_ty1) (Note (Coerce to_ty2 from_ty2) expr) - = ASSERT( from_ty1 == to_ty2 ) - mkNote (Coerce to_ty1 from_ty2) expr - -mkNote (SCC cc1) expr@(Note (SCC cc2) _) - | isDupdCC cc1 -- Discard the outer SCC provided we don't need - = expr -- to track its entry count - -mkNote note@(SCC cc1) expr@(Lam x e) -- Move _scc_ inside lambda - = Lam x (mkNote note e) - --- Drop trivial InlineMe's -mkNote InlineMe expr@(Con _ _) = expr -mkNote InlineMe expr@(Var v) = expr - --- Slide InlineCall in around the function --- No longer necessary I think (SLPJ Apr 99) --- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a --- mkNote InlineCall (Var v) = Note InlineCall (Var v) --- mkNote InlineCall expr = expr - -mkNote note expr = Note note expr +mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr + -- This guy constructs the value that the scrutinee must have + -- when you are in one particular branch of a case +mkAltExpr (DataAlt con) args inst_tys + = mkConApp con (map Type inst_tys ++ map varToCoreExpr args) +mkAltExpr (LitAlt lit) [] [] + = Lit lit \end{code} + %************************************************************************ %* * \subsection{Simple access functions} @@ -302,12 +316,6 @@ rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] rhssOfAlts :: [Alt b] -> [Expr b] rhssOfAlts alts = [e | (_,_,e) <- alts] -isDeadBinder :: CoreBndr -> Bool -isDeadBinder bndr | isId bndr = case getIdOccInfo bndr of - IAmDead -> True - other -> False - | otherwise = False -- TyVars count as not dead - flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds @@ -421,7 +429,7 @@ valArgCount (other : args) = 1 + valArgCount args \begin{code} seqExpr :: CoreExpr -> () seqExpr (Var v) = v `seq` () -seqExpr (Con c as) = seqExprs as +seqExpr (Lit lit) = lit `seq` () seqExpr (App f a) = seqExpr f `seq` seqExpr a seqExpr (Lam b e) = seqBndr b `seq` seqExpr e seqExpr (Let b e) = seqBind b `seq` seqExpr e @@ -465,17 +473,18 @@ exprSize :: CoreExpr -> Int -- A measure of the size of the expressions -- It also forces the expression pretty drastically as a side effect exprSize (Var v) = varSize v -exprSize (Con c as) = c `seq` exprsSize as +exprSize (Lit lit) = 1 exprSize (App f a) = exprSize f + exprSize a exprSize (Lam b e) = varSize b + exprSize e exprSize (Let b e) = bindSize b + exprSize e exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as exprSize (Note n e) = exprSize e -exprSize (Type t) = seqType t `seq` 1 +exprSize (Type t) = seqType t `seq` + 1 exprsSize = foldr ((+) . exprSize) 0 -varSize :: IdOrTyVar -> Int +varSize :: Var -> Int varSize b | isTyVar b = 1 | otherwise = seqType (idType b) `seq` megaSeqIdInfo (idInfo b) `seq` @@ -503,7 +512,7 @@ type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) data AnnExpr' bndr annot = AnnVar Id - | AnnCon Con [AnnExpr bndr annot] + | AnnLit Literal | AnnLam bndr (AnnExpr bndr annot) | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) | AnnCase (AnnExpr bndr annot) bndr [AnnAlt bndr annot] @@ -511,7 +520,7 @@ data AnnExpr' bndr annot | AnnNote Note (AnnExpr bndr annot) | AnnType Type -type AnnAlt bndr annot = (Con, [bndr], AnnExpr bndr annot) +type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) data AnnBind bndr annot = AnnNonRec bndr (AnnExpr bndr annot) @@ -520,21 +529,22 @@ data AnnBind bndr annot \begin{code} deAnnotate :: AnnExpr bndr annot -> Expr bndr +deAnnotate (_, e) = deAnnotate' e -deAnnotate (_, AnnType t) = Type t -deAnnotate (_, AnnVar v) = Var v -deAnnotate (_, AnnCon con args) = Con con (map deAnnotate args) -deAnnotate (_, AnnLam binder body)= Lam binder (deAnnotate body) -deAnnotate (_, AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) -deAnnotate (_, AnnNote note body) = Note note (deAnnotate body) +deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnVar v) = Var v +deAnnotate' (AnnLit lit) = Lit lit +deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) +deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) +deAnnotate' (AnnNote note body) = Note note (deAnnotate body) -deAnnotate (_, AnnLet bind body) +deAnnotate' (AnnLet bind body) = Let (deAnnBind bind) (deAnnotate body) where deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] -deAnnotate (_, AnnCase scrut v alts) +deAnnotate' (AnnCase scrut v alts) = Case (deAnnotate scrut) v (map deAnnAlt alts) where deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index bdf688f7b5..3f5626ddb0 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -19,16 +19,16 @@ import Rules ( ProtoCoreRule(..) ) import UsageSPInf ( doUsageSPInf ) import VarEnv import VarSet -import Var ( Id, IdOrTyVar ) +import Var ( Id, Var ) import Id ( idType, idInfo, idName, mkVanillaId, mkId, exportWithOrigOccName, - getIdStrictness, setIdStrictness, - getIdDemandInfo, setIdDemandInfo, + idStrictness, setIdStrictness, + idDemandInfo, setIdDemandInfo, ) import IdInfo ( specInfo, setSpecInfo, inlinePragInfo, setInlinePragInfo, InlinePragInfo(..), setUnfoldingInfo, setDemandInfo, - workerInfo, setWorkerInfo + workerInfo, setWorkerInfo, WorkerInfo(..) ) import Demand ( wwLazy ) import Name ( getOccName, tidyTopName, mkLocalName, isLocallyDefined ) @@ -102,8 +102,11 @@ tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested -> (TidyEnv, CoreBind) tidyBind maybe_mod env (NonRec bndr rhs) = let - (env', bndr') = tidy_bndr maybe_mod env env bndr - rhs' = tidyExpr env rhs + (env', bndr') = tidy_bndr maybe_mod env' env bndr + rhs' = tidyExpr env' rhs + -- We use env' when tidying the RHS even though it's not + -- strictly necessary; it makes the code pretty hard to read + -- if we don't! in (env', NonRec bndr' rhs') @@ -123,7 +126,7 @@ tidyBind maybe_mod env (Rec pairs) (env', Rec (zip bndrs' rhss')) tidyExpr env (Type ty) = Type (tidyType env ty) -tidyExpr env (Con con args) = Con con (map (tidyExpr env) args) +tidyExpr env (Lit lit) = Lit lit tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e) @@ -168,11 +171,11 @@ tidy_bndr Nothing env_idinfo env var = tidyBndr env var %************************************************************************ \begin{code} -tidyBndr :: TidyEnv -> IdOrTyVar -> (TidyEnv, IdOrTyVar) +tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) tidyBndr env var | isTyVar var = tidyTyVar env var | otherwise = tidyId env var -tidyBndrs :: TidyEnv -> [IdOrTyVar] -> (TidyEnv, [IdOrTyVar]) +tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) tidyBndrs env vars = mapAccumL tidyBndr env vars tidyId :: TidyEnv -> Id -> (TidyEnv, Id) @@ -185,8 +188,8 @@ tidyId env@(tidy_env, var_env) id (tidy_env', occ') = tidyOccName tidy_env (getOccName id) ty' = tidyType env (idType id) id' = mkVanillaId name' ty' - `setIdStrictness` getIdStrictness id - `setIdDemandInfo` getIdDemandInfo id + `setIdStrictness` idStrictness id + `setIdDemandInfo` idDemandInfo id -- NB: This throws away the IdInfo of the Id, which we -- no longer need. That means we don't need to -- run over it with env, nor renumber it. @@ -235,8 +238,8 @@ tidyIdInfo env info info4 = info3 `setDemandInfo` wwLazy -- I don't understand why... info5 = case workerInfo info of - Nothing -> info4 - Just w -> info4 `setWorkerInfo` Just (tidyVarOcc env w) + NoWorker -> info4 + HasWorker w a -> info4 `setWorkerInfo` HasWorker (tidyVarOcc env w) a tidyProtoRules :: TidyEnv -> [ProtoCoreRule] -> [ProtoCoreRule] tidyProtoRules env rules diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index a7a23a3ce5..bf76243c72 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -19,15 +19,13 @@ module CoreUnfold ( noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding, mkOtherCon, otherCons, unfoldingTemplate, maybeUnfoldingTemplate, - isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding, + isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding, hasUnfolding, hasSomeUnfolding, couldBeSmallEnoughToInline, - certainlySmallEnoughToInline, + certainlyWillInline, okToUnfoldInHiFile, - calcUnfoldingGuidance, - callSiteInline, blackListed ) where @@ -39,7 +37,7 @@ import CmdLineOpts ( opt_UF_CreationThreshold, opt_UF_FunAppDiscount, opt_UF_PrimArgDiscount, opt_UF_KeenessFactor, - opt_UF_CheapOp, opt_UF_DearOp, opt_UF_NoRepLit, + opt_UF_CheapOp, opt_UF_DearOp, opt_UnfoldCasms, opt_PprStyle_Debug, opt_D_dump_inlinings ) @@ -47,22 +45,22 @@ import CoreSyn import PprCore ( pprCoreExpr ) import OccurAnal ( occurAnalyseGlobalExpr ) import BinderInfo ( ) -import CoreUtils ( coreExprType, exprIsTrivial, exprIsValue, exprIsCheap ) -import Id ( Id, idType, idUnique, isId, getIdWorkerInfo, - getIdSpecialisation, getInlinePragma, getIdUnfolding, - isConstantId_maybe +import CoreUtils ( exprIsValue, exprIsCheap, exprIsBottom, exprIsTrivial ) +import Id ( Id, idType, idFlavour, idUnique, isId, idWorkerInfo, + idSpecialisation, idInlinePragma, idUnfolding, + isPrimOpId_maybe ) import VarSet import Name ( isLocallyDefined ) -import Const ( Con(..), isLitLitLit, isWHNFCon ) -import PrimOp ( PrimOp(..), primOpIsDupable ) -import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), insideLam, workerExists ) +import Literal ( isLitLitLit ) +import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm ) +import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..), insideLam, workerExists ) import TyCon ( tyConFamilySize ) import Type ( splitAlgTyConApp_maybe, splitFunTy_maybe, isUnLiftedType ) -import Const ( isNoRepLit ) import Unique ( Unique, buildIdKey, augmentIdKey ) import Maybes ( maybeToBool ) import Bag +import List ( maximumBy ) import Util ( isIn, lengthExceeds ) import Outputable @@ -81,7 +79,7 @@ import GlaExts ( fromInt ) data Unfolding = NoUnfolding - | OtherCon [Con] -- It ain't one of these + | OtherCon [AltCon] -- It ain't one of these -- (OtherCon xs) also indicates that something has been evaluated -- and hence there's no point in re-evaluating it. -- OtherCon [] is used even for non-data-type values @@ -100,11 +98,12 @@ data Unfolding -- if you inline this in more than one place Bool -- exprIsValue template (cached); it is ok to discard a `seq` on -- this variable + Bool -- exprIsBottom template (cached) UnfoldingGuidance -- Tells about the *size* of the template. seqUnfolding :: Unfolding -> () -seqUnfolding (CoreUnfolding e top b1 b2 g) - = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g +seqUnfolding (CoreUnfolding e top b1 b2 b3 g) + = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g seqUnfolding other = () \end{code} @@ -112,48 +111,63 @@ seqUnfolding other = () noUnfolding = NoUnfolding mkOtherCon = OtherCon -mkTopUnfolding expr = mkUnfolding True expr +mkTopUnfolding cpr_info expr = mkUnfolding True {- Top level -} cpr_info expr -mkUnfolding top_lvl expr +mkUnfolding top_lvl cpr_info expr = CoreUnfolding (occurAnalyseGlobalExpr expr) top_lvl (exprIsCheap expr) (exprIsValue expr) - (calcUnfoldingGuidance opt_UF_CreationThreshold expr) + (exprIsBottom expr) + (calcUnfoldingGuidance opt_UF_CreationThreshold cpr_info expr) + -- Sometimes during simplification, there's a large let-bound thing + -- which has been substituted, and so is now dead; so 'expr' contains + -- two copies of the thing while the occurrence-analysed expression doesn't + -- Nevertheless, we don't occ-analyse before computing the size because the + -- size computation bales out after a while, whereas occurrence analysis does not. + -- + -- This can occasionally mean that the guidance is very pessimistic; + -- it gets fixed up next round mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded = CompulsoryUnfolding (occurAnalyseGlobalExpr expr) unfoldingTemplate :: Unfolding -> CoreExpr -unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr -unfoldingTemplate (CompulsoryUnfolding expr) = expr +unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr +unfoldingTemplate (CompulsoryUnfolding expr) = expr unfoldingTemplate other = panic "getUnfoldingTemplate" maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr -maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr -maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr -maybeUnfoldingTemplate other = Nothing +maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr +maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr +maybeUnfoldingTemplate other = Nothing otherCons (OtherCon cons) = cons otherCons other = [] +isValueUnfolding :: Unfolding -> Bool + -- Returns False for OtherCon +isValueUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald +isValueUnfolding other = False + isEvaldUnfolding :: Unfolding -> Bool -isEvaldUnfolding (OtherCon _) = True -isEvaldUnfolding (CoreUnfolding _ _ _ is_evald _) = is_evald -isEvaldUnfolding other = False + -- Returns True for OtherCon +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald +isEvaldUnfolding other = False isCheapUnfolding :: Unfolding -> Bool -isCheapUnfolding (CoreUnfolding _ _ is_cheap _ _) = is_cheap -isCheapUnfolding other = False +isCheapUnfolding (CoreUnfolding _ _ is_cheap _ _ _) = is_cheap +isCheapUnfolding other = False isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding (CompulsoryUnfolding _) = True isCompulsoryUnfolding other = False hasUnfolding :: Unfolding -> Bool -hasUnfolding (CoreUnfolding _ _ _ _ _) = True -hasUnfolding (CompulsoryUnfolding _) = True -hasUnfolding other = False +hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True +hasUnfolding (CompulsoryUnfolding _) = True +hasUnfolding other = False hasSomeUnfolding :: Unfolding -> Bool hasSomeUnfolding NoUnfolding = False @@ -198,12 +212,31 @@ instance Outputable UnfoldingGuidance where \begin{code} calcUnfoldingGuidance :: Int -- bomb out if size gets bigger than this + -> CprInfo -- CPR info for this RHS -> CoreExpr -- expression to look at -> UnfoldingGuidance -calcUnfoldingGuidance bOMB_OUT_SIZE expr +calcUnfoldingGuidance bOMB_OUT_SIZE cpr_info expr = case collect_val_bndrs expr of { (inline, val_binders, body) -> let n_val_binders = length val_binders + +-- max_inline_size = n_val_binders+2 + -- The idea is that if there is an INLINE pragma (inline is True) + -- and there's a big body, we give a size of n_val_binders+2. This + -- This is just enough to fail the no-size-increase test in callSiteInline, + -- so that INLINE things don't get inlined into entirely boring contexts, + -- but no more. + +-- Experimental thing commented in for now + max_inline_size = case cpr_info of + NoCPRInfo -> n_val_binders + 2 + ReturnsCPR -> n_val_binders + 1 + + -- However, the wrapper for a CPR'd function is particularly good to inline, + -- even in a boring context, because we may get to do update in place: + -- let x = case y of { I# y# -> I# (y# +# 1#) } + -- Hence the case on cpr_info + in case (sizeExpr bOMB_OUT_SIZE val_binders body) of @@ -213,8 +246,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr -- have an UnfoldIfGoodArgs guidance | inline -> UnfoldIfGoodArgs n_val_binders (map (const 0) val_binders) - (n_val_binders + 2) 0 - -- See comments with final_size below + max_inline_size 0 SizeIs size cased_args scrut_discount -> UnfoldIfGoodArgs @@ -225,43 +257,17 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr where boxed_size = I# size - final_size | inline = 0 -- Trying very agresssive inlining of INLINE things. - -- Reason: we don't want to call the un-inlined version, - -- because its body is awful - -- boxed_size `min` (n_val_binders + 2) -- Trying "+2" again... + final_size | inline = boxed_size `min` max_inline_size | otherwise = boxed_size - -- The idea is that if there is an INLINE pragma (inline is True) - -- and there's a big body, we give a size of n_val_binders+1. This - -- This is enough to pass the no-size-increase test in callSiteInline, - -- but no more. - -- I tried n_val_binders+2, to just defeat the test, on the grounds that - -- we don't want to inline an INLINE thing into a totally boring context, - -- but I found that some wrappers (notably one for a join point) weren't - -- getting inlined, and that was terrible. In that particular case, the - -- call site applied the wrapper to realWorld#, so if we made that an - -- "interesting" value the inlining would have happened... but it was - -- simpler to inline wrappers a little more eagerly instead. - -- - -- Sometimes, though, an INLINE thing is smaller than n_val_binders+2. + + -- Sometimes an INLINE thing is smaller than n_val_binders+2. -- A particular case in point is a constructor, which has size 1. -- We want to inline this regardless, hence the `min` - discount_for b - | num_cases == 0 = 0 - | is_fun_ty = num_cases * opt_UF_FunAppDiscount - | is_data_ty = num_cases * opt_UF_ScrutConDiscount - | otherwise = num_cases * opt_UF_PrimArgDiscount - where - num_cases = foldlBag (\n b' -> if b==b' then n+1 else n) 0 cased_args - -- Count occurrences of b in cased_args - arg_ty = idType b - is_fun_ty = maybeToBool (splitFunTy_maybe arg_ty) - (is_data_ty, tycon) = case (splitAlgTyConApp_maybe (idType b)) of - Nothing -> (False, panic "discount") - Just (tc,_,_) -> (True, tc) + discount_for b = foldlBag (\acc (b',n) -> if b==b' then acc+n else acc) + 0 cased_args } where - collect_val_bndrs e = go False [] e -- We need to be a bit careful about how we collect the -- value binders. In ptic, if we see @@ -291,13 +297,11 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr size_up (Note _ body) = size_up body -- Notes cost nothing size_up (App fun (Type t)) = size_up fun - size_up (App fun arg) = size_up_app fun [arg] + size_up (App fun arg) = size_up_app fun [arg] - size_up (Con con args) = foldr (addSize . nukeScrutDiscount . size_up) - (size_up_con con args) - args + size_up (Lit lit) = sizeOne - size_up (Lam b e) | isId b = size_up e `addSizeN` 1 + size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 1) | otherwise = size_up e size_up (Let (NonRec binder rhs) body) @@ -314,38 +318,92 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr where rhs_size = foldr (addSize . size_up . snd) sizeZero pairs - size_up (Case scrut _ alts) - = nukeScrutDiscount (size_up scrut) `addSize` - arg_discount scrut `addSize` - foldr (addSize . size_up_alt) sizeZero alts - `addSizeN` 1 -- charge one for the case itself. - --- Just charge for the alts that exist, not the ones that might exist --- `addSizeN` --- case (splitAlgTyConApp_maybe (coreExprType scrut)) of --- Nothing -> 1 --- Just (tc,_,_) -> tyConFamilySize tc + -- We want to make wrapper-style evaluation look cheap, so that + -- when we inline a wrapper it doesn't make call site (much) bigger + -- Otherwise we get nasty phase ordering stuff: + -- f x = g x x + -- h y = ...(f e)... + -- If we inline g's wrapper, f looks big, and doesn't get inlined + -- into h; if we inline f first, while it looks small, then g's + -- wrapper will get inlined later anyway. To avoid this nasty + -- ordering difference, we make (case a of (x,y) -> ...) look free. + size_up (Case (Var v) _ [alt]) + | v `elem` top_args + = size_up_alt alt `addSize` SizeIs 0# (unitBag (v, 1)) 0# + -- Good to inline if an arg is scrutinised, because + -- that may eliminate allocation in the caller + -- And it eliminates the case itself + | otherwise + = size_up_alt alt + + -- Scrutinising one of the argument variables, + -- with more than one alternative + size_up (Case (Var v) _ alts) + | v `elem` top_args + = alts_size (foldr addSize sizeOne alt_sizes) -- The 1 is for the scrutinee + (foldr1 maxSize alt_sizes) + where + v_in_args = v `elem` top_args + alt_sizes = map size_up_alt alts + + alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives + (SizeIs max max_disc max_scrut) -- Size of biggest alternative + = SizeIs tot (unitBag (v, I# (1# +# tot -# max)) `unionBags` max_disc) max_scrut + -- If the variable is known, we produce a discount that + -- will take us back to 'max', the size of rh largest alternative + -- The 1+ is a little discount for reduced allocation in the caller + + alts_size tot_size _ = tot_size + + + size_up (Case e _ alts) = nukeScrutDiscount (size_up e) `addSize` + foldr (addSize . size_up_alt) sizeZero alts + -- We don't charge for the case itself + -- It's a strict thing, and the price of the call + -- is paid by scrut. Also consider + -- case f x of DEFAULT -> e + -- This is just ';'! Don't charge for it. ------------ - size_up_app (App fun arg) args = size_up_app fun (arg:args) + size_up_app (App fun arg) args + | isTypeArg arg = size_up_app fun args + | otherwise = size_up_app fun (arg:args) size_up_app fun args = foldr (addSize . nukeScrutDiscount . size_up) (size_up_fun fun args) args -- A function application with at least one value argument -- so if the function is an argument give it an arg-discount + -- -- Also behave specially if the function is a build + -- -- Also if the function is a constant Id (constr or primop) - -- compute discounts as if it were actually a Con; in the early - -- stages these constructors and primops may not yet be inlined - size_up_fun (Var fun) args | idUnique fun == buildIdKey = buildSize - | idUnique fun == augmentIdKey = augmentSize - | fun `is_elem` top_args = scrutArg fun `addSize` fun_size - | otherwise = fun_size - where - fun_size = case isConstantId_maybe fun of - Just con -> size_up_con con args - Nothing -> sizeOne + -- compute discounts specially + size_up_fun (Var fun) args + | idUnique fun == buildIdKey = buildSize + | idUnique fun == augmentIdKey = augmentSize + | otherwise + = case idFlavour fun of + DataConId dc -> conSizeN (valArgCount args) + + PrimOpId op -> primOpSize op (valArgCount args) + -- foldr addSize (primOpSize op) (map arg_discount args) + -- At one time I tried giving an arg-discount if a primop + -- is applied to one of the function's arguments, but it's + -- not good. At the moment, any unlifted-type arg gets a + -- 'True' for 'yes I'm evald', so we collect the discount even + -- if we know nothing about it. And just having it in a primop + -- doesn't help at all if we don't know something more. + + other -> fun_discount fun `addSizeN` + (1 + length (filter (not . exprIsTrivial) args)) + -- The 1+ is for the function itself + -- Add 1 for each non-trivial arg; + -- the allocation cost, as in let(rec) + -- Slight hack here: for constructors the args are almost always + -- trivial; and for primops they are almost always prim typed + -- We should really only count for non-prim-typed args in the + -- general case, but that seems too much like hard work size_up_fun other args = size_up other @@ -354,42 +412,26 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr -- Don't charge for args, so that wrappers look cheap ------------ - size_up_con (Literal lit) args | isNoRepLit lit = sizeN opt_UF_NoRepLit - | otherwise = sizeOne - - size_up_con (DataCon dc) args = conSizeN (valArgCount args) - - size_up_con (PrimOp op) args = foldr addSize (sizeN op_cost) (map arg_discount args) - -- Give an arg-discount if a primop is applies to - -- one of the function's arguments - where - op_cost | primOpIsDupable op = opt_UF_CheapOp - | otherwise = opt_UF_DearOp - -- We want to record if we're case'ing, or applying, an argument - arg_discount (Var v) | v `is_elem` top_args = scrutArg v - arg_discount other = sizeZero - - ------------ - is_elem :: Id -> [Id] -> Bool - is_elem = isIn "size_up_scrut" + fun_discount v | v `elem` top_args = SizeIs 0# (unitBag (v, opt_UF_FunAppDiscount)) 0# + fun_discount other = sizeZero ------------ -- These addSize things have to be here because -- I don't want to give them bOMB_OUT_SIZE as an argument - addSizeN TooBig _ = TooBig + addSizeN TooBig _ = TooBig addSizeN (SizeIs n xs d) (I# m) - | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d - | otherwise = TooBig + | n_tot ># bOMB_OUT_SIZE = TooBig + | otherwise = SizeIs n_tot xs d where n_tot = n +# m addSize TooBig _ = TooBig addSize _ TooBig = TooBig addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) - | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot - | otherwise = TooBig + | n_tot ># bOMB_OUT_SIZE = TooBig + | otherwise = SizeIs n_tot xys d_tot where n_tot = n1 +# n2 d_tot = d1 +# d2 @@ -401,20 +443,34 @@ Code for manipulating sizes \begin{code} data ExprSize = TooBig - | SizeIs Int# -- Size found - (Bag Id) -- Arguments cased herein - Int# -- Size to subtract if result is scrutinised - -- by a case expression + | SizeIs Int# -- Size found + (Bag (Id,Int)) -- Arguments cased herein, and discount for each such + Int# -- Size to subtract if result is scrutinised + -- by a case expression + +isTooBig TooBig = True +isTooBig _ = False + +maxSize TooBig _ = TooBig +maxSize _ TooBig = TooBig +maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1 + | otherwise = s2 sizeZero = SizeIs 0# emptyBag 0# sizeOne = SizeIs 1# emptyBag 0# sizeTwo = SizeIs 2# emptyBag 0# sizeN (I# n) = SizeIs n emptyBag 0# conSizeN (I# n) = SizeIs 1# emptyBag (n +# 1#) - -- Treat constructors as size 1, that unfoldAlways responsds 'False' - -- when asked about 'x' when x is bound to (C 3#). - -- This avoids gratuitous 'ticks' when x itself appears as an - -- atomic constructor argument. + -- Treat constructors as size 1; we are keen to expose them + -- (and we charge separately for their args). We can't treat + -- them as size zero, else we find that (I# x) has size 1, + -- which is the same as a lone variable; and hence 'v' will + -- always be replaced by (I# x), where v is bound to I# x. + +primOpSize op n_args + | not (primOpIsDupable op) = sizeN opt_UF_DearOp + | not (primOpOutOfLine op) = sizeZero -- These are good to inline + | otherwise = sizeOne buildSize = SizeIs (-2#) emptyBag 4# -- We really want to inline applications of build @@ -428,10 +484,12 @@ augmentSize = SizeIs (-2#) emptyBag 4# -- Ditto (augment t (\cn -> e) ys) should cost only the cost of -- e plus ys. The -2 accounts for the \cn -scrutArg v = SizeIs 0# (unitBag v) 0# - nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0# nukeScrutDiscount TooBig = TooBig + +-- When we return a lambda, give a discount if it's used (applied) +lamScrutDiscount (SizeIs n vs d) = case opt_UF_FunAppDiscount of { I# d -> SizeIs n vs d } +lamScrutDiscount TooBig = TooBig \end{code} @@ -470,13 +528,26 @@ use'' on the other side. Can be overridden w/ flaggery. Just the same as smallEnoughToInline, except that it has no actual arguments. \begin{code} -couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool -couldBeSmallEnoughToInline UnfoldNever = False -couldBeSmallEnoughToInline other = True - -certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool -certainlySmallEnoughToInline UnfoldNever = False -certainlySmallEnoughToInline (UnfoldIfGoodArgs _ _ size _) = size <= opt_UF_UseThreshold +couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool +couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold NoCPRInfo rhs of + UnfoldNever -> False + other -> True + +certainlyWillInline :: Id -> Bool + -- Sees if the Id is pretty certain to inline +certainlyWillInline v + = case idUnfolding v of + + CoreUnfolding _ _ _ is_value _ (UnfoldIfGoodArgs n_vals _ size _) + -> is_value + && size - (n_vals +1) <= opt_UF_UseThreshold + && not never_inline + + other -> False + where + never_inline = case idInlinePragma v of + IMustNotBeINLINEd False Nothing -> True + other -> False \end{code} @okToUnfoldInHifile@ is used when emitting unfolding info into an interface @@ -495,10 +566,10 @@ okToUnfoldInHiFile :: CoreExpr -> Bool okToUnfoldInHiFile e = opt_UnfoldCasms || go e where -- Race over an expression looking for CCalls.. - go (Var _) = True - go (Con (Literal lit) _) = not (isLitLitLit lit) - go (Con (PrimOp op) args) = okToUnfoldPrimOp op && all go args - go (Con con args) = all go args -- might be litlits in here + go (Var v) = case isPrimOpId_maybe v of + Just op -> okToUnfoldPrimOp op + Nothing -> True + go (Lit lit) = not (isLitLitLit lit) go (App fun arg) = go fun && go arg go (Lam _ body) = go body go (Let binds body) = and (map go (body :rhssOfBind binds)) @@ -507,8 +578,8 @@ okToUnfoldInHiFile e = opt_UnfoldCasms || go e go (Type _) = True -- ok to unfold a PrimOp as long as it's not a _casm_ - okToUnfoldPrimOp (CCallOp _ is_casm _ _) = not is_casm - okToUnfoldPrimOp _ = True + okToUnfoldPrimOp (CCallOp ccall) = not (ccallIsCasm ccall) + okToUnfoldPrimOp _ = True \end{code} @@ -529,6 +600,11 @@ and occurs exactly once or If the thing is in WHNF, there's no danger of duplicating work, so we can inline if it occurs once, or is small +NOTE: we don't want to inline top-level functions that always diverge. +It just makes the code bigger. Tt turns out that the convenient way to prevent +them inlining is to give them a NOINLINE pragma, which we do in +StrictAnal.addStrictnessInfoToTopId + \begin{code} callSiteInline :: Bool -- True <=> the Id is black listed -> Bool -- 'inline' note at call site @@ -540,15 +616,15 @@ callSiteInline :: Bool -- True <=> the Id is black listed callSiteInline black_listed inline_call occ id arg_infos interesting_cont - = case getIdUnfolding id of { + = case idUnfolding id of { NoUnfolding -> Nothing ; OtherCon _ -> Nothing ; CompulsoryUnfolding unf_template | black_listed -> Nothing | otherwise -> Just unf_template ; - -- Primops have compulsory unfoldings, but + -- Constructors have compulsory unfoldings, but -- may have rules, in which case they are -- black listed till later - CoreUnfolding unf_template is_top is_cheap _ guidance -> + CoreUnfolding unf_template is_top is_cheap _ is_bot guidance -> let result | yes_or_no = Just unf_template @@ -556,13 +632,16 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont n_val_args = length arg_infos + ok_inside_lam = is_cheap || is_bot -- I'm experimenting with is_cheap + -- instead of is_value + yes_or_no | black_listed = False | otherwise = case occ of IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False IAmALoopBreaker -> False - OneOcc in_lam one_br -> (not in_lam || is_cheap) && consider_safe in_lam True one_br - NoOccInfo -> is_cheap && consider_safe True False False + OneOcc in_lam one_br -> (not in_lam || ok_inside_lam) && consider_safe in_lam True one_br + NoOccInfo -> ok_inside_lam && consider_safe True False False consider_safe in_lam once once_in_one_branch -- consider_safe decides whether it's a good idea to inline something, @@ -570,11 +649,25 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont -- once_in_one_branch = True means there's a unique textual occurrence | inline_call = True - | once_in_one_branch -- Be very keen to inline something if this is its unique occurrence; that - -- gives a good chance of eliminating the original binding for the thing. - -- The only time we hold back is when substituting inside a lambda; - -- then if the context is totally uninteresting (not applied, not scrutinised) - -- there is no point in substituting because it might just increase allocation. + | once_in_one_branch + -- Be very keen to inline something if this is its unique occurrence: + -- + -- a) Inlining gives a good chance of eliminating the original + -- binding (and hence the allocation) for the thing. + -- (Provided it's not a top level binding, in which case the + -- allocation costs nothing.) + -- + -- b) Inlining a function that is called only once exposes the + -- body function to the call site. + -- + -- The only time we hold back is when substituting inside a lambda; + -- then if the context is totally uninteresting (not applied, not scrutinised) + -- there is no point in substituting because it might just increase allocation, + -- by allocating the function itself many times + -- + -- Note: there used to be a '&& not top_level' in the guard above, + -- but that stopped us inlining top-level functions used only once, + -- which is stupid = not in_lam || not (null arg_infos) || interesting_cont | otherwise @@ -592,7 +685,7 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont where some_benefit = or arg_infos || really_interesting_cont || - (not is_top && (once || (n_vals_wanted > 0 && enough_args))) + (not is_top && (once || (n_vals_wanted > 0 && enough_args))) -- If it occurs more than once, there must be something interesting -- about some argument, or the result context, to make it worth inlining -- @@ -610,9 +703,9 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont really_interesting_cont | n_val_args < n_vals_wanted = False -- Too few args | n_val_args == n_vals_wanted = interesting_cont | otherwise = True -- Extra args - -- really_interesting_cont tells if the result of the - -- call is in an interesting context. - + -- really_interesting_cont tells if the result of the + -- call is in an interesting context. + small_enough = (size - discount) <= opt_UF_UseThreshold discount = computeDiscount n_vals_wanted arg_discounts res_discount arg_infos really_interesting_cont @@ -625,7 +718,9 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont text "occ info:" <+> ppr occ, text "arg infos" <+> ppr arg_infos, text "interesting continuation" <+> ppr interesting_cont, - text "is cheap" <+> ppr is_cheap, + text "is cheap:" <+> ppr is_cheap, + text "is bottom:" <+> ppr is_bot, + text "is top-level:" <+> ppr is_top, text "guidance" <+> ppr guidance, text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO", if yes_or_no then @@ -703,29 +798,15 @@ blackListed :: IdSet -- Used in transformation rules -- place that the inline phase number is looked at. blackListed rule_vars Nothing -- Last phase - = \v -> case getInlinePragma v of + = \v -> case idInlinePragma v of IMustNotBeINLINEd False Nothing -> True -- An unconditional NOINLINE pragma other -> False -blackListed rule_vars (Just 0) --- Phase 0: used for 'no imported inlinings please' --- This prevents wrappers getting inlined which in turn is bad for full laziness --- NEW: try using 'not a wrapper' rather than 'not imported' in this phase. --- This allows a little more inlining, which seems to be important, sometimes. --- For example PrelArr.newIntArr gets better. - = \v -> -- workerExists (getIdWorkerInfo v) || normal_case rule_vars 0 v - -- True -- Try going back to no inlinings at all - -- BUT: I found that there is some advantage in doing - -- local inlinings first. For example in fish/Main.hs - -- it's advantageous to inline scale_vec2 before inlining - -- wrappers from PrelNum that make it look big. - not (isLocallyDefined v) || normal_case rule_vars 0 v -- This seems best at the moment - blackListed rule_vars (Just phase) = \v -> normal_case rule_vars phase v normal_case rule_vars phase v - = case getInlinePragma v of + = case idInlinePragma v of NoInlinePragInfo -> has_rules IMustNotBeINLINEd from_INLINE Nothing @@ -737,7 +818,7 @@ normal_case rule_vars phase v | otherwise -> phase < threshold || has_rules where has_rules = v `elemVarSet` rule_vars - || not (isEmptyCoreRules (getIdSpecialisation v)) + || not (isEmptyCoreRules (idSpecialisation v)) \end{code} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 6ecd4a5851..c30c17bb69 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -5,12 +5,20 @@ \begin{code} module CoreUtils ( - coreExprType, coreAltsType, + exprType, coreAltsType, + + mkNote, mkInlineMe, mkSCC, mkCoerce, exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, - exprIsValue, - exprOkForSpeculation, exprIsBig, hashExpr, - exprArity, exprEtaExpandArity, + exprIsValue,exprOkForSpeculation, exprIsBig, + exprArity, + + idAppIsBottom, idAppIsCheap, + + etaReduceExpr, exprEtaExpandArity, + + hashExpr, + cheapEqExpr, eqExpr, applyTypeToArgs ) where @@ -22,28 +30,28 @@ import {-# SOURCE #-} CoreUnfold ( isEvaldUnfolding ) import GlaExts -- For `xori` import CoreSyn +import CoreFVs ( exprFreeVars ) import PprCore ( pprCoreExpr ) -import Var ( IdOrTyVar, isId, isTyVar ) +import Var ( isId, isTyVar ) import VarSet import VarEnv import Name ( isLocallyDefined, hashName ) -import Const ( Con(..), isWHNFCon, conIsTrivial, conIsCheap, conIsDupable, - conType, hashCon +import Literal ( Literal, hashLiteral, literalType ) +import PrimOp ( primOpOkForSpeculation, primOpIsCheap ) +import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo, + idArity, idName, idUnfolding, idInfo ) -import PrimOp ( primOpOkForSpeculation, primOpStrictness ) -import Id ( Id, idType, setIdType, idUnique, idAppIsBottom, - getIdArity, idName, isPrimitiveId_maybe, - getIdSpecialisation, setIdSpecialisation, - getInlinePragma, setInlinePragma, - getIdUnfolding, setIdUnfolding, idInfo +import IdInfo ( arityLowerBound, InlinePragInfo(..), + LBVarInfo(..), + IdFlavour(..), + appIsBottom ) -import IdInfo ( arityLowerBound, InlinePragInfo(..), lbvarInfo, LBVarInfo(..) ) import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes, isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..), - tidyTyVar, applyTys, isUnLiftedType + applyTys, isUnLiftedType ) -import Demand ( isPrim, isLazy ) +import CostCentre ( CostCentre ) import Unique ( buildIdKey, augmentIdKey ) import Util ( zipWithEqual, mapAccumL ) import Outputable @@ -58,32 +66,30 @@ import TysPrim ( alphaTy ) -- Debugging only %************************************************************************ \begin{code} -coreExprType :: CoreExpr -> Type - -coreExprType (Var var) = idType var -coreExprType (Let _ body) = coreExprType body -coreExprType (Case _ _ alts) = coreAltsType alts -coreExprType (Note (Coerce ty _) e) = ty -- **! should take usage from e -coreExprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (coreExprType e)) -coreExprType (Note other_note e) = coreExprType e -coreExprType e@(Con con args) = ASSERT2( all (\ a -> case a of { Type ty -> isNotUsgTy ty; _ -> True }) args, ppr e) - applyTypeToArgs e (conType con) args - -coreExprType (Lam binder expr) - | isId binder = (case (lbvarInfo . idInfo) binder of +exprType :: CoreExpr -> Type + +exprType (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Let _ body) = exprType body +exprType (Case _ _ alts) = coreAltsType alts +exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e +exprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (exprType e)) +exprType (Note other_note e) = exprType e +exprType (Lam binder expr) + | isId binder = (case idLBVarInfo binder of IsOneShotLambda -> mkUsgTy UsOnce otherwise -> id) $ - idType binder `mkFunTy` coreExprType expr - | isTyVar binder = mkForAllTy binder (coreExprType expr) + idType binder `mkFunTy` exprType expr + | isTyVar binder = mkForAllTy binder (exprType expr) -coreExprType e@(App _ _) +exprType e@(App _ _) = case collectArgs e of - (fun, args) -> applyTypeToArgs e (coreExprType fun) args + (fun, args) -> applyTypeToArgs e (exprType fun) args -coreExprType other = pprTrace "coreExprType" (pprCoreExpr other) alphaTy +exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy coreAltsType :: [CoreAlt] -> Type -coreAltsType ((_,_,rhs) : _) = coreExprType rhs +coreAltsType ((_,_,rhs) : _) = exprType rhs \end{code} \begin{code} @@ -93,7 +99,9 @@ applyTypeToArgs e op_ty [] = op_ty applyTypeToArgs e op_ty (Type ty : args) = -- Accumulate type arguments so we can instantiate all at once - ASSERT2( all isNotUsgTy tys, ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+> ppr (Type ty : args) <+> text "i.e." <+> ppr tys ) + ASSERT2( all isNotUsgTy tys, + ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+> + ppr (Type ty : args) <+> text "i.e." <+> ppr tys ) applyTypeToArgs e (applyTys op_ty tys) rest_args where (tys, rest_args) = go [ty] args @@ -106,6 +114,66 @@ applyTypeToArgs e op_ty (other_arg : args) Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e) \end{code} + + +%************************************************************************ +%* * +\subsection{Attaching notes +%* * +%************************************************************************ + +mkNote removes redundant coercions, and SCCs where possible + +\begin{code} +mkNote :: Note -> CoreExpr -> CoreExpr +mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr +mkNote (SCC cc) expr = mkSCC cc expr +mkNote InlineMe expr = mkInlineMe expr +mkNote note expr = Note note expr + +-- Slide InlineCall in around the function +-- No longer necessary I think (SLPJ Apr 99) +-- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a +-- mkNote InlineCall (Var v) = Note InlineCall (Var v) +-- mkNote InlineCall expr = expr +\end{code} + +Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding +that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may +not be *applied* to anything. + +\begin{code} +mkInlineMe e | exprIsTrivial e = e + | otherwise = Note InlineMe e +\end{code} + + + +\begin{code} +mkCoerce :: Type -> Type -> Expr b -> Expr b +-- In (mkCoerce to_ty from_ty e), we require that from_ty = exprType e +-- But exprType is defined in CoreUtils, so we don't check the assertion + +mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr) + = ASSERT( from_ty == to_ty2 ) + mkCoerce to_ty from_ty2 expr + +mkCoerce to_ty from_ty expr + | to_ty == from_ty = expr + | otherwise = Note (Coerce to_ty from_ty) expr +\end{code} + +\begin{code} +mkSCC :: CostCentre -> Expr b -> Expr b + -- Note: Nested SCC's *are* preserved for the benefit of + -- cost centre stack profiling (Durham) + +mkSCC cc (Lit lit) = Lit lit +mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda +mkSCC cc expr = Note (SCC cc) expr +\end{code} + + %************************************************************************ %* * \subsection{Figuring out things about expressions} @@ -121,10 +189,10 @@ applyTypeToArgs e op_ty (other_arg : args) \begin{code} exprIsTrivial (Type _) = True +exprIsTrivial (Lit lit) = True exprIsTrivial (Var v) = True exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e exprIsTrivial (Note _ e) = exprIsTrivial e -exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body exprIsTrivial other = False \end{code} @@ -143,14 +211,17 @@ exprIsTrivial other = False \begin{code} exprIsDupable (Type _) = True -exprIsDupable (Con con args) = conIsDupable con && - all exprIsDupable args && - valArgCount args <= dupAppSize - +exprIsDupable (Var v) = True +exprIsDupable (Lit lit) = True exprIsDupable (Note _ e) = exprIsDupable e -exprIsDupable expr = case collectArgs expr of - (Var f, args) -> all exprIsDupable args && valArgCount args <= dupAppSize - other -> False +exprIsDupable expr + = go expr 0 + where + go (Var v) n_args = True + go (App f a) n_args = n_args < dupAppSize + && exprIsDupable a + && go f (n_args+1) + go other n_args = False dupAppSize :: Int dupAppSize = 4 -- Size of application we are prepared to duplicate @@ -189,34 +260,50 @@ because sharing will make sure it is only evaluated once. \begin{code} exprIsCheap :: CoreExpr -> Bool -exprIsCheap (Type _) = True -exprIsCheap (Var _) = True -exprIsCheap (Con con args) = conIsCheap con && all exprIsCheap args -exprIsCheap (Note _ e) = exprIsCheap e -exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e -exprIsCheap other_expr -- look for manifest partial application - = case collectArgs other_expr of - (f, args) -> isPap f (valArgCount args) && all exprIsCheap args -\end{code} - -\begin{code} -isPap :: CoreExpr -- Function - -> Int -- Number of value args - -> Bool -isPap (Var f) n_val_args - = idAppIsBottom f n_val_args - -- Application of a function which - -- always gives bottom; we treat this as - -- a WHNF, because it certainly doesn't - -- need to be shared! - - || n_val_args == 0 -- Just a type application of +exprIsCheap (Lit lit) = True +exprIsCheap (Type _) = True +exprIsCheap (Var _) = True +exprIsCheap (Note _ e) = exprIsCheap e +exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e +exprIsCheap (Case (Var v) _ alts) = and [exprIsCheap rhs | (_,_,rhs) <- alts] + -- Experimentally, treat (case x of ...) as cheap + -- This improves arities of overloaded functions where + -- there is only dictionary selection (no construction) involved +exprIsCheap other_expr + = go other_expr 0 True + where + go (Var f) n_args args_cheap + = (idAppIsCheap f n_args && args_cheap) + -- A constructor, cheap primop, or partial application + + || idAppIsBottom f n_args + -- Application of a function which + -- always gives bottom; we treat this as + -- a WHNF, because it certainly doesn't + -- need to be shared! + + go (App f a) n_args args_cheap + | isTypeArg a = go f n_args args_cheap + | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap) + + go other n_args args_cheap = False + +idAppIsCheap :: Id -> Int -> Bool +idAppIsCheap id n_val_args + | n_val_args == 0 = True -- Just a type application of -- a variable (f t1 t2 t3) -- counts as WHNF - - || n_val_args < arityLowerBound (getIdArity f) - -isPap fun n_val_args = False + | otherwise = case idFlavour id of + DataConId _ -> True + RecordSelId _ -> True -- I'm experimenting with making record selection + -- look cheap, so we will substitute it inside a + -- lambda. Particularly for dictionary field selection + + PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops + -- that return a type variable, since the result + -- might be applied to something, but I'm not going + -- to bother to check the number of args + other -> n_val_args < idArity id \end{code} exprOkForSpeculation returns True of an expression that it is @@ -247,35 +334,29 @@ side effects, and can't diverge or raise an exception. \begin{code} exprOkForSpeculation :: CoreExpr -> Bool -exprOkForSpeculation (Var v) = isUnLiftedType (idType v) -exprOkForSpeculation (Note _ e) = exprOkForSpeculation e - -exprOkForSpeculation (Con (Literal _) args) = True -exprOkForSpeculation (Con (DataCon _) args) = True - -- The strictness of the constructor has already - -- been expressed by its "wrapper", so we don't need - -- to take the arguments into account - -exprOkForSpeculation (Con (PrimOp op) args) - = prim_op_ok_for_spec op args - -exprOkForSpeculation (App fun arg) -- Might be application of a primop - = go fun [arg] +exprOkForSpeculation (Lit _) = True +exprOkForSpeculation (Var v) = isUnLiftedType (idType v) +exprOkForSpeculation (Note _ e) = exprOkForSpeculation e +exprOkForSpeculation other_expr + = go other_expr 0 True where - go (App fun arg) args = go fun (arg:args) - go (Var v) args = case isPrimitiveId_maybe v of - Just op -> prim_op_ok_for_spec op args - Nothing -> False - go other args = False - -exprOkForSpeculation other = False -- Conservative - -prim_op_ok_for_spec op args - = primOpOkForSpeculation op && - and (zipWith ok (filter isValArg args) (fst (primOpStrictness op))) - where - ok arg demand | isLazy demand = True - | otherwise = exprOkForSpeculation arg + go (Var f) n_args args_ok + = case idFlavour f of + DataConId _ -> True -- The strictness of the constructor has already + -- been expressed by its "wrapper", so we don't need + -- to take the arguments into account + + PrimOpId op -> primOpOkForSpeculation op && args_ok + -- A bit conservative: we don't really need + -- to care about lazy arguments, but this is easy + + other -> False + + go (App f a) n_args args_ok + | isTypeArg a = go f n_args args_ok + | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok) + + go other n_args args_ok = False \end{code} @@ -289,8 +370,11 @@ exprIsBottom e = go 0 e go n (Case e _ _) = go 0 e -- Just check the scrut go n (App e _) = go (n+1) e go n (Var v) = idAppIsBottom v n - go n (Con _ _) = False + go n (Lit _) = False go n (Lam _ _) = False + +idAppIsBottom :: Id -> Int -> Bool +idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args \end{code} @exprIsValue@ returns true for expressions that are certainly *already* @@ -305,17 +389,31 @@ So, it does *not* treat variables as evaluated, unless they say they are exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind -- copying them -exprIsValue (Var v) = isEvaldUnfolding (getIdUnfolding v) +exprIsValue (Lit l) = True exprIsValue (Lam b e) = isId b || exprIsValue e exprIsValue (Note _ e) = exprIsValue e -exprIsValue (Let _ e) = False -exprIsValue (Case _ _ _) = False -exprIsValue (Con con _) = isWHNFCon con -exprIsValue e@(App _ _) = case collectArgs e of - (Var v, args) -> fun_arity > valArgCount args - where - fun_arity = arityLowerBound (getIdArity v) - _ -> False +exprIsValue other_expr + = go other_expr 0 + where + go (Var f) n_args = idAppIsValue f n_args + + go (App f a) n_args + | isTypeArg a = go f n_args + | otherwise = go f (n_args + 1) + + go (Note _ f) n_args = go f n_args + + go other n_args = False + +idAppIsValue :: Id -> Int -> Bool +idAppIsValue id n_val_args + = case idFlavour id of + DataConId _ -> True + PrimOpId _ -> n_val_args < idArity id + other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id) + | otherwise -> n_val_args < idArity id + -- A worry: what if an Id's unfolding is just itself: + -- then we could get an infinite loop... \end{code} \begin{code} @@ -338,6 +436,46 @@ exprArity other = 0 \end{code} +%************************************************************************ +%* * +\subsection{Eta reduction and expansion} +%* * +%************************************************************************ + +@etaReduceExpr@ trys an eta reduction at the top level of a Core Expr. + +e.g. \ x y -> f x y ===> f + +But we only do this if it gets rid of a whole lambda, not part. +The idea is that lambdas are often quite helpful: they indicate +head normal forms, so we don't want to chuck them away lightly. + +\begin{code} +etaReduceExpr :: CoreExpr -> CoreExpr + -- ToDo: we should really check that we don't turn a non-bottom + -- lambda into a bottom variable. Sigh + +etaReduceExpr expr@(Lam bndr body) + = check (reverse binders) body + where + (binders, body) = collectBinders expr + + check [] body + | not (any (`elemVarSet` body_fvs) binders) + = body -- Success! + where + body_fvs = exprFreeVars body + + check (b : bs) (App fun arg) + | (varToCoreExpr b `cheapEqExpr` arg) + = check bs fun + + check _ _ = expr -- Bale out + +etaReduceExpr expr = expr -- The common case +\end{code} + + \begin{code} exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be applied to -- without doing much work @@ -350,32 +488,34 @@ exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be ap -- We are prepared to evaluate x each time round the loop in order to get that -- Hence "generous" arity -exprEtaExpandArity (Var v) = arityLowerBound (getIdArity v) -exprEtaExpandArity (Lam x e) - | isId x = 1 + exprEtaExpandArity e - | otherwise = exprEtaExpandArity e -exprEtaExpandArity (Let bind body) - | all exprIsCheap (rhssOfBind bind) = exprEtaExpandArity body -exprEtaExpandArity (Case scrut _ alts) - | exprIsCheap scrut = min_zero [exprEtaExpandArity rhs | (_,_,rhs) <- alts] - -exprEtaExpandArity (Note note e) - | ok_note note = exprEtaExpandArity e +exprEtaExpandArity e + = go e where + go (Var v) = idArity v + go (App f (Type _)) = go f + go (App f a) | exprIsCheap a = (go f - 1) `max` 0 -- Never go -ve! + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Note n e) | ok_note n = go e + go (Case scrut _ alts) + | exprIsCheap scrut = min_zero [go rhs | (_,_,rhs) <- alts] + go (Let b e) + | all exprIsCheap (rhssOfBind b) = go e + + go other = 0 + ok_note (Coerce _ _) = True ok_note InlineCall = True ok_note other = False - -- Notice that we do not look through __inline_me__ - -- This one is a bit more surprising, but consider - -- f = _inline_me (\x -> e) - -- We DO NOT want to eta expand this to - -- f = \x -> (_inline_me (\x -> e)) x - -- because the _inline_me gets dropped now it is applied, - -- giving just - -- f = \x -> e - -- A Bad Idea - -exprEtaExpandArity other = 0 -- Could do better for applications + -- Notice that we do not look through __inline_me__ + -- This one is a bit more surprising, but consider + -- f = _inline_me (\x -> e) + -- We DO NOT want to eta expand this to + -- f = \x -> (_inline_me (\x -> e)) x + -- because the _inline_me gets dropped now it is applied, + -- giving just + -- f = \x -> e + -- A Bad Idea min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest min_zero (x:xs) = go x xs @@ -401,24 +541,21 @@ min_zero (x:xs) = go x xs \begin{code} cheapEqExpr :: Expr b -> Expr b -> Bool -cheapEqExpr (Var v1) (Var v2) = v1==v2 -cheapEqExpr (Con con1 args1) (Con con2 args2) - = con1 == con2 && - and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2) +cheapEqExpr (Var v1) (Var v2) = v1==v2 +cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2 +cheapEqExpr (Type t1) (Type t2) = t1 == t2 cheapEqExpr (App f1 a1) (App f2 a2) = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 -cheapEqExpr (Type t1) (Type t2) = t1 == t2 - cheapEqExpr _ _ = False exprIsBig :: Expr b -> Bool -- Returns True of expressions that are too big to be compared by cheapEqExpr +exprIsBig (Lit _) = False exprIsBig (Var v) = False exprIsBig (Type t) = False exprIsBig (App f a) = exprIsBig f || exprIsBig a -exprIsBig (Con _ args) = any exprIsBig args exprIsBig other = True \end{code} @@ -436,7 +573,7 @@ eqExpr e1 e2 Just v1' -> v1' == v2 Nothing -> v1 == v2 - eq env (Con c1 es1) (Con c2 es2) = c1 == c2 && eq_list env es1 es2 + eq env (Lit lit1) (Lit lit2) = lit1 == lit2 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2 eq env (Let (NonRec v1 r1) e1) @@ -480,29 +617,27 @@ eqExpr e1 e2 \begin{code} hashExpr :: CoreExpr -> Int -hashExpr e = abs (hash_expr e) - -- Negative numbers kill UniqFM +hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt + | otherwise = hash + where + hash = abs (hash_expr e) -- Negative numbers kill UniqFM hash_expr (Note _ e) = hash_expr e hash_expr (Let (NonRec b r) e) = hashId b hash_expr (Let (Rec ((b,r):_)) e) = hashId b hash_expr (Case _ b _) = hashId b -hash_expr (App f e) = hash_expr f + fast_hash_expr e +hash_expr (App f e) = hash_expr f * fast_hash_expr e hash_expr (Var v) = hashId v -hash_expr (Con con args) = foldr ((+) . fast_hash_expr) (hashCon con) args +hash_expr (Lit lit) = hashLiteral lit hash_expr (Lam b _) = hashId b -hash_expr (Type t) = trace "hash_expr: type" 0 -- Shouldn't happen +hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen fast_hash_expr (Var v) = hashId v -fast_hash_expr (Con con args) = fast_hash_args args con +fast_hash_expr (Lit lit) = hashLiteral lit fast_hash_expr (App f (Type _)) = fast_hash_expr f fast_hash_expr (App f a) = fast_hash_expr a fast_hash_expr (Lam b _) = hashId b -fast_hash_expr other = 0 - -fast_hash_args [] con = hashCon con -fast_hash_args (Type t : args) con = fast_hash_args args con -fast_hash_args (arg : args) con = fast_hash_expr arg +fast_hash_expr other = 1 hashId :: Id -> Int hashId id = hashName (idName id) diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 92db05f2e3..d17e8b73d6 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -18,16 +18,17 @@ module PprCore ( import CoreSyn import CostCentre ( pprCostCentreCore ) -import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, getIdOccInfo, Id ) +import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity, + idInfo, idInlinePragma, idDemandInfo, idOccInfo + ) import Var ( isTyVar ) -import IdInfo ( IdInfo, +import IdInfo ( IdInfo, megaSeqIdInfo, arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo, demandInfo, updateInfo, ppUpdateInfo, specInfo, strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo, cprInfo, ppCprInfo, lbvarInfo, workerInfo, ppWorkerInfo ) -import Const ( Con(..), DataCon ) import DataCon ( isTupleCon, isUnboxedTupleCon ) import PprType ( pprParendType, pprTyVarBndr ) import PprEnv @@ -63,8 +64,8 @@ pprParendExpr :: CoreExpr -> SDoc pprCoreBindings = pprTopBinds pprCoreEnv pprCoreBinding = pprTopBind pprCoreEnv -pprCoreExpr = ppr_expr pprCoreEnv -pprParendExpr = ppr_parend_expr pprCoreEnv +pprCoreExpr = ppr_noparend_expr pprCoreEnv +pprParendExpr = ppr_parend_expr pprCoreEnv pprCoreEnv = initCoreEnv pprCoreBinder \end{code} @@ -86,7 +87,7 @@ instance Outputable b => Outputable (Bind b) where ppr bind = ppr_bind pprGenericEnv bind instance Outputable b => Outputable (Expr b) where - ppr expr = ppr_expr pprGenericEnv expr + ppr expr = ppr_noparend_expr pprGenericEnv expr pprGenericEnv :: Outputable b => PprEnv b pprGenericEnv = initCoreEnv (\site -> ppr) @@ -102,7 +103,6 @@ pprGenericEnv = initCoreEnv (\site -> ppr) \begin{code} initCoreEnv pbdr = initPprEnv - (Just ppr) -- Constants (Just pprCostCentreCore) -- Cost centres (Just ppr) -- tyvar occs @@ -122,7 +122,7 @@ initCoreEnv pbdr pprTopBinds pe binds = vcat (map (pprTopBind pe) binds) pprTopBind pe (NonRec binder expr) - = sep [ppr_binding_pe pe (binder,expr)] $$ text "" + = ppr_binding_pe pe (binder,expr) $$ text "" pprTopBind pe (Rec binds) = vcat [ptext SLIT("Rec {"), @@ -142,73 +142,72 @@ ppr_bind pe (Rec binds) = vcat (map pp binds) ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc ppr_binding_pe pe (val_bdr, expr) = sep [pBndr pe LetBind val_bdr, - nest 2 (equals <+> ppr_expr pe expr)] + nest 2 (equals <+> ppr_noparend_expr pe expr)] \end{code} \begin{code} -ppr_parend_expr pe expr - | no_parens = ppr_expr pe expr - | otherwise = parens (ppr_expr pe expr) - where - no_parens = case expr of - Var _ -> True - Con con [] -> True - Con (DataCon dc) _ -> isTupleCon dc - _ -> False +ppr_parend_expr pe expr = ppr_expr parens pe expr +ppr_noparend_expr pe expr = ppr_expr noParens pe expr + +noParens :: SDoc -> SDoc +noParens pp = pp \end{code} \begin{code} -ppr_expr :: PprEnv b -> Expr b -> SDoc - -ppr_expr pe (Type ty) = ptext SLIT("TYPE") <+> ppr ty -- Wierd - -ppr_expr pe (Var name) = pOcc pe name - -ppr_expr pe (Con con []) - = ppr con -- Nullary constructors too +ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) -ppr_expr pe (Con (DataCon dc) args) - -- Drop the type arguments and print in (a,b,c) notation - | isTupleCon dc - = parens (sep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args)))) - | isUnboxedTupleCon dc - = text "(# " <> - hsep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))) <> - text " #)" - -ppr_expr pe (Con con args) - = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args)) +ppr_expr add_par pe (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd + +ppr_expr add_par pe (Var name) = pOcc pe name +ppr_expr add_par pe (Lit lit) = ppr lit -ppr_expr pe expr@(Lam _ _) +ppr_expr add_par pe expr@(Lam _ _) = let (bndrs, body) = collectBinders expr in + add_par $ hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow) - 4 (ppr_expr pe body) - -ppr_expr pe expr@(App fun arg) - = let - (final_fun, final_args) = go fun [arg] - go (App fun arg) args_so_far = go fun (arg:args_so_far) - go fun args_so_far = (fun, args_so_far) + 4 (ppr_noparend_expr pe body) + +ppr_expr add_par pe expr@(App fun arg) + = case collectArgs expr of { (fun, args) -> + let + pp_args = sep (map (ppr_arg pe) args) + val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples + pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args)) in - hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args)) - -ppr_expr pe (Case expr var [(con,args,rhs)]) - = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr, + case fun of + Var f -> case isDataConId_maybe f of + -- Notice that we print the *worker* + -- for tuples in paren'd format. + Just dc | saturated && isTupleCon dc -> parens pp_tup_args + | saturated && isUnboxedTupleCon dc -> text "(#" <+> pp_tup_args <+> text "#)" + other -> add_par (hang (pOcc pe f) 4 pp_args) + where + saturated = length val_args == idArity f + + other -> add_par (hang (ppr_parend_expr pe fun) 4 pp_args) + } + +ppr_expr add_par pe (Case expr var [(con,args,rhs)]) + = add_par $ + sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr, hsep [ptext SLIT("of"), ppr_bndr var, char '{', ppr_case_pat pe con args ]], - ppr_expr pe rhs, + ppr_noparend_expr pe rhs, char '}' ] where ppr_bndr = pBndr pe CaseBind -ppr_expr pe (Case expr var alts) - = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr, +ppr_expr add_par pe (Case expr var alts) + = add_par $ + sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr, ptext SLIT("of") <+> ppr_bndr var <+> char '{'], nest 4 (sep (punctuate semi (map ppr_alt alts))), char '}' @@ -217,41 +216,45 @@ ppr_expr pe (Case expr var alts) ppr_bndr = pBndr pe CaseBind ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args) - 4 (ppr_expr pe rhs) + 4 (ppr_noparend_expr pe rhs) -- special cases: let ... in let ... -- ("disgusting" SLPJ) -ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) - = vcat [ +ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) + = add_par $ + vcat [ hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals], - nest 2 (ppr_expr pe rhs), + nest 2 (ppr_noparend_expr pe rhs), ptext SLIT("} in"), - ppr_expr pe body ] + ppr_noparend_expr pe body ] -ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) - = hang (ptext SLIT("let {")) +ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) + = add_par + (hang (ptext SLIT("let {")) 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals]) - 4 (ppr_expr pe rhs), + 4 (ppr_noparend_expr pe rhs), ptext SLIT("} in")]) - $$ - ppr_expr pe expr + $$ + ppr_noparend_expr pe expr) -- general case (recursive case, too) -ppr_expr pe (Let bind expr) - = sep [hang (ptext keyword) 2 (ppr_bind pe bind), - hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)] +ppr_expr add_par pe (Let bind expr) + = add_par $ + sep [hang (ptext keyword) 2 (ppr_bind pe bind), + hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)] where keyword = case bind of Rec _ -> SLIT("__letrec {") NonRec _ _ -> SLIT("let {") -ppr_expr pe (Note (SCC cc) expr) - = sep [pSCC pe cc, ppr_expr pe expr] +ppr_expr add_par pe (Note (SCC cc) expr) + = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr]) #ifdef DEBUG -ppr_expr pe (Note (Coerce to_ty from_ty) expr) - = getPprStyle $ \ sty -> +ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr) + = add_par $ + getPprStyle $ \ sty -> if debugStyle sty && not (ifaceStyle sty) then sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty], ppr_parend_expr pe expr] @@ -259,25 +262,26 @@ ppr_expr pe (Note (Coerce to_ty from_ty) expr) sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty], ppr_parend_expr pe expr] #else -ppr_expr pe (Note (Coerce to_ty from_ty) expr) - = sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)], +ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr) + = add_par $ + sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)], ppr_parend_expr pe expr] #endif -ppr_expr pe (Note InlineCall expr) - = ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr +ppr_expr add_par pe (Note InlineCall expr) + = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr) -ppr_expr pe (Note InlineMe expr) - = ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr +ppr_expr add_par pe (Note InlineMe expr) + = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr -ppr_expr pe (Note (TermUsg u) expr) - = \ sty -> +ppr_expr add_par pe (Note (TermUsg u) expr) + = getPprStyle $ \ sty -> if ifaceStyle sty then - ppr_expr pe expr sty + ppr_expr add_par pe expr else - (ppr u <+> ppr_expr pe expr) sty + add_par (ppr u <+> ppr_noparend_expr pe expr) -ppr_case_pat pe con@(DataCon dc) args +ppr_case_pat pe con@(DataAlt dc) args | isTupleCon dc = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow | isUnboxedTupleCon dc @@ -289,7 +293,7 @@ ppr_case_pat pe con@(DataCon dc) args ppr_bndr = pBndr pe CaseBind ppr_case_pat pe con args - = pCon pe con <+> hsep (map ppr_bndr args) <+> arrow + = ppr con <+> hsep (map ppr_bndr args) <+> arrow where ppr_bndr = pBndr pe CaseBind @@ -334,8 +338,11 @@ pprTypedBinder binder -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ... -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness -pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdOccInfo id) <+> - ppr (getIdDemandInfo id)) <+> ppr (lbvarInfo (idInfo id)) +pprIdBndr id = ppr id <+> + (megaSeqIdInfo (idInfo id) `seq` + -- Useful for poking on black holes + ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+> + ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id)) \end{code} diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index cc473cd063..ab51482543 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -44,15 +44,17 @@ import Type ( ThetaType, PredType(..), ClassContext, import VarSet import VarEnv import Var ( setVarUnique, isId ) -import Id ( idType, setIdType, getIdOccInfo, zapFragileIdInfo ) +import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo ) import Name ( isLocallyDefined ) import IdInfo ( IdInfo, isFragileOccInfo, specInfo, setSpecInfo, - workerExists, workerInfo, setWorkerInfo, WorkerInfo + WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo ) +import BasicTypes ( OccInfo(..) ) import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply ) -import Var ( Var, IdOrTyVar, Id, TyVar, isTyVar ) +import Var ( Var, Id, TyVar, isTyVar ) import Outputable +import PprCore () -- Instances import Util ( mapAccumL, foldl2, seqList, ($!) ) \end{code} @@ -96,6 +98,10 @@ The general plan about the substitution and in-scope set for Ids is as follows * substId adds a binding (DoneVar new_id occ) to the substitution if EITHER the Id's unique has changed OR the Id has interesting occurrence information + So in effect you can only get to interesting occurrence information + by looking up the *old* Id; it's not really attached to the new id + at all. + Note, though that the substitution isn't necessarily extended if the type changes. Why not? Because of the next point: @@ -162,18 +168,28 @@ lookupIdSubst :: Subst -> Id -> SubstResult -- Does the lookup in the in-scope set too lookupIdSubst (Subst in_scope env) v = case lookupSubstEnv env v of - Just (DoneId v' occ) -> case lookupVarEnv in_scope v' of - Just v'' -> DoneId v'' occ - Nothing -> DoneId v' occ + Just (DoneId v' occ) -> DoneId (lookupInScope in_scope v') occ Just res -> res - Nothing -> DoneId v' (getIdOccInfo v') + Nothing -> DoneId v' (idOccInfo v') + -- We don't use DoneId for LoopBreakers, so the idOccInfo is + -- very important! If isFragileOccInfo returned True for + -- loop breakers we could avoid this call, but at the expense + -- of adding more to the substitution, and building new Ids + -- in substId a bit more often than really necessary where - v' = case lookupVarEnv in_scope v of - Just v' -> v' - Nothing -> v - -lookupInScope :: Subst -> Var -> Maybe Var -lookupInScope (Subst in_scope _) v = lookupVarEnv in_scope v + v' = lookupInScope in_scope v + +lookupInScope :: InScopeSet -> Var -> Var +-- It's important to look for a fixed point +-- When we see (case x of y { I# v -> ... }) +-- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder). +-- When we lookup up an occurrence of x, we map to y, but then +-- we want to look up y in case it has acquired more evaluation information by now. +lookupInScope in_scope v + = case lookupVarEnv in_scope v of + Just v' | v == v' -> v' -- Reached a fixed point + | otherwise -> lookupInScope in_scope v' + Nothing -> v isInScope :: Var -> Subst -> Bool isInScope v (Subst in_scope _) = v `elemVarEnv` in_scope @@ -363,7 +379,7 @@ substExpr subst expr DoneEx e' -> e' go (Type ty) = Type (go_ty ty) - go (Con con args) = Con con (map go args) + go (Lit lit) = Lit lit go (App fun arg) = App (go fun) (go arg) go (Note note e) = Note (go_note note) (go e) @@ -403,12 +419,12 @@ When we hit a binder we may need to (c) give it a new unique to avoid name clashes \begin{code} -substBndr :: Subst -> IdOrTyVar -> (Subst, IdOrTyVar) +substBndr :: Subst -> Var -> (Subst, Var) substBndr subst bndr | isTyVar bndr = substTyVar subst bndr | otherwise = substId subst bndr -substBndrs :: Subst -> [IdOrTyVar] -> (Subst, [IdOrTyVar]) +substBndrs :: Subst -> [Var] -> (Subst, [Var]) substBndrs subst bndrs = mapAccumL substBndr subst bndrs @@ -424,7 +440,7 @@ substId subst@(Subst in_scope env) old_id = (Subst (in_scope `add_in_scope` new_id) new_env, new_id) where id_ty = idType old_id - occ_info = getIdOccInfo old_id + occ_info = idOccInfo old_id -- id1 has its type zapped id1 | noTypeSubst env @@ -511,17 +527,17 @@ substWorker :: Subst -> WorkerInfo -> WorkerInfo -- Seq'ing on the returned WorkerInfo is enough to cause all the -- substitutions to happen completely -substWorker subst Nothing - = Nothing -substWorker subst (Just w) +substWorker subst NoWorker + = NoWorker +substWorker subst (HasWorker w a) = case lookupSubst subst w of - Nothing -> Just w - Just (DoneId w1 _) -> Just w1 - Just (DoneEx (Var w1)) -> Just w1 + Nothing -> HasWorker w a + Just (DoneId w1 _) -> HasWorker w1 a + Just (DoneEx (Var w1)) -> HasWorker w1 a Just (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w ) - Nothing -- Worker has got substituted away altogether - Just (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w ) - Nothing -- Ditto + NoWorker -- Worker has got substituted away altogether + Just (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e) + NoWorker -- Ditto substRules :: Subst -> CoreRules -> CoreRules -- Seq'ing on the returned CoreRules is enough to cause all the diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index 6c491e29d6..be1c7481bd 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -9,18 +9,17 @@ module CprAnalyse ( cprAnalyse ) where import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_cpranal ) import CoreLint ( beginPass, endPass ) import CoreSyn -import CoreUtils ( coreExprType ) +import CoreUtils ( exprIsValue ) import CoreUnfold ( maybeUnfoldingTemplate ) import Var ( Var, Id, TyVar, idType, varName, varType ) -import Id ( setIdCprInfo, getIdCprInfo, getIdUnfolding, getIdArity, +import Id ( setIdCprInfo, idCprInfo, idArity, isBottomingId ) -import IdInfo ( CprInfo(..), arityLowerBound ) +import IdInfo ( CprInfo(..) ) import VarEnv -import Type ( Type, splitFunTys, splitFunTy_maybe, splitForAllTys, splitNewType_maybe ) -import TyCon ( isProductTyCon, isNewTyCon, isUnLiftedTyCon ) -import DataCon ( dataConTyCon, splitProductType_maybe, dataConRawArgTys ) -import Const ( Con(DataCon), isDataCon, isWHNFCon ) -import Util ( zipEqual, zipWithEqual ) +import Type ( Type, splitFunTys, splitFunTy_maybe, splitForAllTys ) +import TyCon ( isNewTyCon, isUnLiftedTyCon ) +import DataCon ( dataConTyCon ) +import Util ( zipEqual, zipWithEqual, nTimes, mapAccumL ) import Outputable import UniqFM (ufmToList) @@ -88,9 +87,12 @@ functions by an abstract constant function. \begin{code} data AbsVal = Top -- Not a constructed product + | Fun AbsVal -- A function that takes an argument -- and gives AbsVal as result. - | Tuple [AbsVal] -- A constructed product of values + + | Tuple -- A constructed product of values + | Bot -- Bot'tom included for convenience -- we could use appropriate Tuple Vals deriving (Eq,Show) @@ -101,12 +103,10 @@ isFun _ = False -- For pretty debugging instance Outputable AbsVal where - ppr Top = ptext SLIT("Top") - ppr (Fun r) = ptext SLIT("Fun->") <> (parens.ppr) r - ppr (Tuple la) = ptext SLIT("Tuple ") <> text "[" <> - (hsep (punctuate comma (map ppr la))) <> - text "]" - ppr Bot = ptext SLIT("Bot") + ppr Top = ptext SLIT("Top") + ppr (Fun r) = ptext SLIT("Fun->") <> (parens.ppr) r + ppr Tuple = ptext SLIT("Tuple ") + ppr Bot = ptext SLIT("Bot") -- lub takes the lowest upper bound of two abstract values, standard. @@ -115,7 +115,7 @@ lub Bot a = a lub a Bot = a lub Top a = Top lub a Top = Top -lub (Tuple l) (Tuple r) = Tuple (zipWithEqual "CPR: lub" lub l r) +lub Tuple Tuple = Tuple lub (Fun l) (Fun r) = Fun (lub l r) lub l r = panic "CPR Analysis tried to take the lub of a function and a tuple" @@ -152,15 +152,7 @@ cprAnalyse binds } where do_prog :: [CoreBind] -> [CoreBind] - do_prog binds - = snd $ foldl analBind (initCPREnv, []) binds - where - analBind :: (CPREnv, [CoreBind]) -> CoreBind -> (CPREnv, [CoreBind]) - analBind (rho,done_binds) bind - = (extendVarEnvList rho env, done_binds ++ [bind']) - where - (env, bind') = cprAnalTopBind rho bind - + do_prog binds = snd $ mapAccumL cprAnalBind initCPREnv binds \end{code} The cprAnal functions take binds/expressions and an environment which @@ -168,29 +160,37 @@ gives CPR info for visible ids and returns a new bind/expression with ids decorated with their CPR info. \begin{code} --- Return environment updated with info from this binding -cprAnalTopBind :: CPREnv -> CoreBind -> ([(Var, AbsVal)], CoreBind) -cprAnalTopBind rho (NonRec v e) - = ([(v', e_absval')], NonRec v' e_pluscpr) - where - (e_pluscpr, e_absval) = cprAnalExpr rho e - (v', e_absval') = pinCPR v e e_absval - --- When analyzing mutually recursive bindings the iterations to find --- a fixpoint is bounded by the number of bindings in the group. --- for simplicity we just iterate that number of times. -cprAnalTopBind rho (Rec bounders) - = (map (\(b,e) -> (b, lookupVarEnv_NF fin_rho b)) fin_bounders', - Rec fin_bounders') - where - init_rho = rho `extendVarEnvList` (zip binders (repeat Bot)) - binders = map fst bounders +-- Return environment extended with info from this binding +cprAnalBind :: CPREnv -> CoreBind -> (CPREnv, CoreBind) +cprAnalBind rho (NonRec b e) + = (extendVarEnv rho b absval, NonRec b' e') + where + (e', absval) = cprAnalRhs rho e + b' = setIdCprInfo b (absToCprInfo absval) + +cprAnalBind rho (Rec prs) + = (final_rho, Rec (map do_pr prs)) + where + do_pr (b,e) = (b', e') + where + b' = setIdCprInfo b (absToCprInfo absval) + (e', absval) = cprAnalRhs final_rho e + + -- When analyzing mutually recursive bindings the iterations to find + -- a fixpoint is bounded by the number of bindings in the group. + -- for simplicity we just iterate that number of times. + final_rho = nTimes (length prs) do_one_pass init_rho + init_rho = rho `extendVarEnvList` [(b,Bot) | (b,e) <- prs] + + do_one_pass :: CPREnv -> CPREnv + do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalRhs rho e))) + rho prs + +cprAnalRhs :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal) +cprAnalRhs rho e + = case cprAnalExpr rho e of + (e_pluscpr, e_absval) -> (e_pluscpr, pinCPR e e_absval) - (fin_rho, fin_bounders) = nTimes (length bounders) - do_one_pass - (init_rho, bounders) - fin_bounders' = map (\(b,e) -> (fst $ pinCPR b e (lookupVarEnv_NF fin_rho b), e)) - fin_bounders cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal) @@ -204,43 +204,10 @@ cprAnalExpr rho e@(Var v) | isBottomingId v = (e, Bot) | otherwise = (e, case lookupVarEnv rho v of Just a_val -> a_val - Nothing -> cpr_prag_a_val) - where - ids_inf = (cprInfoToAbs.getIdCprInfo) v - ids_arity = (arityLowerBound.getIdArity) v - cpr_prag_a_val = case ids_inf of - Top -> -- if we can inline this var, and its a constructor app - -- then analyse the unfolding - case (maybeUnfoldingTemplate.getIdUnfolding) v of - Just e | isCon e -> snd $ cprAnalExpr rho e - zz_other -> Top - zz_other -> -- Unfortunately, cprinfo doesn't store the # of args - nTimes ids_arity Fun ids_inf - --- Return constructor with decorated arguments. If constructor --- has product type then this is a manifest constructor (hooray!) -cprAnalExpr rho (Con con args) - = (Con con args_cpr, - -- If we are a product with 0 args we must be void(like) - -- We can't create an unboxed tuple with 0 args for this - -- and since Void has only one, constant value it should - -- just mean returning a pointer to a pre-existing cell. - -- So we won't really gain from doing anything fancy - -- and we treat this case as Top. - if isConProdType con - && length args > 0 - then Tuple args_aval_filt_funs - else Top) - where - anal_con_args = map (cprAnalExpr rho) args - args_cpr = map fst anal_con_args + Nothing -> getCprAbsVal v) - args_aval_filt_funs = if (not.isDataCon) con then - map snd anal_con_args - else - map (ifApply isFun (const Top)) $ - map snd $ - filter (not.isTypeArg.fst) anal_con_args +-- Literals are unboxed +cprAnalExpr rho (Lit l) = (Lit l, Top) -- For apps we don't care about the argument's abs val. This -- app will return a constructed product if the function does. We strip @@ -248,17 +215,21 @@ cprAnalExpr rho (Con con args) -- or it is already Top or Bot. cprAnalExpr rho (App fun arg@(Type _)) = (App fun_cpr arg, fun_res) - where + where (fun_cpr, fun_res) = cprAnalExpr rho fun cprAnalExpr rho (App fun arg) - = (App fun_cpr arg_cpr, if fun_res==Top || fun_res==Bot - then fun_res - else res_res) - where + = (App fun_cpr arg_cpr, res_res) + where (fun_cpr, fun_res) = cprAnalExpr rho fun (arg_cpr, _) = cprAnalExpr rho arg - Fun res_res = fun_res + res_res = case fun_res of + Fun res_res -> res_res + Top -> Top + Bot -> Bot + Tuple -> WARN( True, ppr (App fun arg) ) Top + -- This really should not happen! + -- Map arguments to Top (we aren't constructing them) -- Return the abstract value of the body, since functions @@ -269,26 +240,11 @@ cprAnalExpr rho (Lam b body) | isTyVar b = (Lam b body_cpr, body_aval) where (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body -cprAnalExpr rho (Let (NonRec binder rhs) body) - = (Let (NonRec binder' rhs_cpr) body_cpr, body_aval) - where - (rhs_cpr, rhs_aval) = cprAnalExpr rho rhs - (binder', rhs_aval') = pinCPR binder rhs_cpr rhs_aval - (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho binder rhs_aval') body - -cprAnalExpr rho (Let (Rec bounders) body) - = (Let (Rec fin_bounders) body_cpr, body_aval) - where - (rhs_rho, fin_bounders) = nTimes - (length bounders) - do_one_pass - (init_rho, bounders) - - (body_cpr, body_aval) = cprAnalExpr rhs_rho body - - init_rho = rho `extendVarEnvList` zip binders (repeat Bot) - binders = map fst bounders - +cprAnalExpr rho (Let bind body) + = (Let bind' body', body_aval) + where + (rho', bind') = cprAnalBind rho bind + (body', body_aval) = cprAnalExpr rho' body cprAnalExpr rho (Case scrut bndr alts) = (Case scrut_cpr bndr alts_cpr, alts_aval) @@ -304,7 +260,6 @@ cprAnalExpr rho (Note n exp) cprAnalExpr rho (Type t) = (Type t, Top) - cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal) cprAnalCaseAlts rho alts = foldl anal_alt ([], Bot) alts @@ -316,31 +271,20 @@ cprAnalCaseAlts rho alts rho' = rho `extendVarEnvList` (zip binds (repeat Top)) --- Does one analysis pass through a list of mutually recursive bindings. -do_one_pass :: (CPREnv, [(CoreBndr,CoreExpr)]) -> (CPREnv, [(CoreBndr,CoreExpr)]) -do_one_pass (i_rho,bounders) - = foldl anal_bind (i_rho, []) bounders - where - anal_bind (c_rho, done) (b,e) = (modifyVarEnv (const e_absval') c_rho b, - done ++ [(b,e')]) - where (e', e_absval) = cprAnalExpr c_rho e - e_absval' = snd (pinCPR b e e_absval) - - -- take a binding pair and the abs val calculated from the rhs and -- calculate a new absval taking into account sufficient manifest -- lambda condition -- Also we pin the var's CPR property to it. A var only has the CPR property if -- it is a function -pinCPR :: Var -> CoreExpr -> AbsVal -> (Var, AbsVal) -pinCPR v e av = case av of +pinCPR :: CoreExpr -> AbsVal -> AbsVal +pinCPR e av = case av of -- is v a function with insufficent lambdas? - Fun _ | length argtys /= length val_binders -> + Fun _ | n_fun_tys av /= length val_binders -> -- argtys must be greater than val_binders. So stripped_exp -- has a function type. The head of this expr can't be lambda -- a note, because we stripped them off before. It can't be a - -- Con because it has a function type. It can't be a Type. + -- constructor because it has a function type. It can't be a Type. -- If its an app, let or case then there is work to get the -- and we can't do anything because we may lose laziness. *But* -- if its a var (i.e. a function name) then we are fine. Note @@ -353,109 +297,37 @@ pinCPR v e av = case av of -- if isVar stripped_exp then -- (addCpr av, av) -- else - (addCpr Top, Top) - Tuple _ -> - -- not a function. - -- Pin NoInfo to v. If v appears in the interface file then an - -- importing module will check to see if it has an unfolding - -- with a constructor at its head (WHNF). If it does it will re-analyse - -- the folding. I could do the check here, but I don't know if - -- the current unfolding info is final. - (addCpr Top, - -- Retain CPR info if it has a constructor - -- at its head, and thus will be inlined and simplified by - -- case of a known constructor - if isCon e then av else Top) - _ -> (addCpr av, av) - where - -- func to pin CPR info on a var - addCpr :: AbsVal -> Var - addCpr = (setIdCprInfo v).absToCprInfo + Top - -- Split argument types and result type from v's type - (_, argtys, _) = (splitTypeToFunArgAndRes.varType) v + Tuple | exprIsValue e -> av + | otherwise -> Top + -- If the rhs is a value, and returns a constructed product, + -- it will be inlined at usage sites, so we give it a Tuple absval + -- If it isn't a value, we won't inline it (code/work dup worries), so + -- we discard its absval. - -- val_binders are the explicit lambdas at the head of the expression - (_, val_binders, _) = collectTyAndValBinders e -- collectBindersIgnoringNotes e' + _ -> av + where + n_fun_tys :: AbsVal -> Int + n_fun_tys (Fun av) = 1 + n_fun_tys av + n_fun_tys other = 0 + -- val_binders are the explicit lambdas at the head of the expression + -- Don't get confused by inline pragamas + val_binders = filter isId (fst (collectBindersIgnoringNotes e)) absToCprInfo :: AbsVal -> CprInfo -absToCprInfo (Tuple args) = CPRInfo $ map absToCprInfo args -absToCprInfo (Fun r) = absToCprInfo r -absToCprInfo _ = NoCPRInfo +absToCprInfo Tuple = ReturnsCPR +absToCprInfo (Fun r) = absToCprInfo r +absToCprInfo _ = NoCPRInfo -- Cpr Info doesn't store the number of arguments a function has, so the caller -- must take care to add the appropriate number of Funs. -cprInfoToAbs :: CprInfo -> AbsVal -cprInfoToAbs NoCPRInfo = Top -cprInfoToAbs (CPRInfo args) = Tuple $ map cprInfoToAbs args - -\end{code} - -%************************************************************************ -%* * -\subsection{Utilities} -%* * -%************************************************************************ - - -Now we define a couple of functions that split up types, they should -be moved to Type.lhs if it is agreed that they are doing something -that is sensible. - -\begin{code} - --- Split a function type into forall tyvars, argument types and result type. --- If the type isn't a function type then tyvars and argument types will be --- empty lists. - --- Experimental, look through new types. I have given up on this for now, --- if the target of a function is a new type which is a function (see monadic --- functions for examples) we could look into these. However, it turns out that --- the (necessary) coercions in the code stop the beneficial simplifications. -splitTypeToFunArgAndRes :: Type -> ([TyVar], [Type], Type) -splitTypeToFunArgAndRes ty = (tyvars, argtys, resty) - where (tyvars, funty) = splitForAllTys ty - (argtys, resty) = splitFunTysIgnoringNewTypes funty --- (argtys, resty) = splitFunTys funty - --- splitFunTys, modified to keep searching through newtypes. --- Should move to Type.lhs if it is doing something sensible. - -splitFunTysIgnoringNewTypes :: Type -> ([Type], Type) -splitFunTysIgnoringNewTypes ty = split ty - where - split ty = case splitNewType_maybe res of - Nothing -> (args, res) - Just rep_ty -> (args ++ args', res') - where - (args', res') = split rep_ty - where - (args, res) = splitFunTys ty - - --- Is this the constructor for a product type (i.e. algebraic, single constructor) --- NB: isProductTyCon replies 'False' for unboxed tuples -isConProdType :: Con -> Bool -isConProdType (DataCon con) = isProductTyCon . dataConTyCon $ con -isConProdType _ = False - --- returns True iff head of expression is a constructor --- Should I look through notes? I think so ... -isCon :: CoreExpr -> Bool -isCon (Con c _) = isWHNFCon c -- is this the right test? -isCon (Note _ e) = isCon e -isCon _ = False - --- Compose a function with itself n times. (nth rather than twice) --- This must/should be in a library somewhere, but where! -nTimes :: Int -> (a -> a) -> (a -> a) -nTimes 0 _ = id -nTimes 1 f = f -nTimes n f = f . nTimes (n-1) f - --- Only apply f to argument if it satisfies p -ifApply :: (a -> Bool) -> (a -> a) -> (a -> a) -ifApply p f x = if p x then f x else x - +getCprAbsVal v = case idCprInfo v of + NoCPRInfo -> Top + ReturnsCPR -> nTimes arity Fun Tuple + where + arity = idArity v + -- Imported (non-nullary) constructors will have the CPR property + -- in their IdInfo, so no need to look at their unfolding \end{code} diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index c43f98596d..d67ecfdeea 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -17,7 +17,7 @@ import {-# SOURCE #-} DsExpr( dsExpr ) import HsSyn -- lots of things import CoreSyn -- lots of things -import CoreUtils ( coreExprType ) +import CoreUtils ( exprType, mkInlineMe, mkSCC ) import TcHsSyn ( TypecheckedMonoBinds ) import DsMonad import DsGRHSs ( dsGuarded ) @@ -127,13 +127,13 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest core_binds = [Rec (addLocalInlines exports inlines core_prs)] tup_expr = mkTupleExpr locals - tup_ty = coreExprType tup_expr + tup_ty = exprType tup_expr poly_tup_expr = mkLams all_tyvars $ mkLams dicts $ mkDsLets core_binds tup_expr locals = [local | (_, _, local) <- exports] local_tys = map idType locals in - newSysLocalDs (coreExprType poly_tup_expr) `thenDs` \ poly_tup_id -> + newSysLocalDs (exprType poly_tup_expr) `thenDs` \ poly_tup_id -> let dict_args = map Var dicts @@ -165,7 +165,7 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest \begin{code} mkInline :: Bool -> CoreExpr -> CoreExpr -mkInline True body = Note InlineMe body +mkInline True body = mkInlineMe body mkInline False body = body addLocalInlines :: [(a, Id, Id)] -> NameSet -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] @@ -206,16 +206,16 @@ addAutoScc :: AutoScc -- if needs be, decorate toplevs? addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr) | do_auto_scc && worthSCC core_expr = getModuleDs `thenDs` \ mod -> - returnDs (bndr, Note (SCC (mkAutoCC top_bndr mod NotCafCC)) core_expr) + returnDs (bndr, mkSCC (mkAutoCC top_bndr mod NotCafCC) core_expr) where do_auto_scc = isJust maybe_auto_scc maybe_auto_scc = auto_scc_fn bndr (Just top_bndr) = maybe_auto_scc + addAutoScc _ pair = returnDs pair -worthSCC (Note (SCC _) _) = False -worthSCC (Con _ _) = False -worthSCC core_expr = True +noUserSCC (Note (SCC _) _) = False +worthSCC core_expr = True \end{code} If profiling and dealing with a dict binding, diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 561553f443..35722fae20 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -6,6 +6,7 @@ \begin{code} module DsCCall ( dsCCall + , mkCCall , unboxArg , boxResult , wrapUnboxedValue @@ -21,23 +22,25 @@ import DsMonad import DsUtils import TcHsSyn ( maybeBoxedPrimType ) -import CoreUtils ( coreExprType ) +import CoreUtils ( exprType ) import Id ( Id, mkWildId ) -import Const ( Con(..) ) +import MkId ( mkCCallOpId ) import Maybes ( maybeToBool ) import PrelInfo ( packStringForCId ) -import PrimOp ( PrimOp(..) ) -import DataCon ( DataCon, dataConId, splitProductType_maybe ) +import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) +import DataCon ( DataCon, splitProductType_maybe ) import CallConv import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys, - splitTyConApp_maybe, Type + splitTyConApp_maybe, tyVarsOfType, mkForAllTys, Type ) import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) -import TysWiredIn ( unitDataCon, stringTy, +import TysWiredIn ( unitDataConId, stringTy, unboxedPairDataCon, mkUnboxedTupleTy, unboxedTupleCon ) +import Unique ( Unique ) +import VarSet ( varSetElems ) import Outputable \end{code} @@ -89,21 +92,36 @@ dsCCall lbl args may_gc is_asm result_ty mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> boxResult result_ty `thenDs` \ (final_result_ty, res_wrapper) -> - + getUniqueDs `thenDs` \ uniq -> let - val_args = Var old_s : unboxed_args - final_args = Type inst_ty : val_args - - -- A CCallOp has type (forall a. a), so we must instantiate - -- it at the full type, including the state argument - inst_ty = mkFunTys (map coreExprType val_args) final_result_ty - - the_ccall_op = CCallOp (Left lbl) is_asm may_gc cCallConv - the_prim_app = mkPrimApp the_ccall_op final_args - - the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers + val_args = Var old_s : unboxed_args + the_ccall = CCall (StaticTarget lbl) is_asm may_gc cCallConv + the_prim_app = mkCCall uniq the_ccall val_args final_result_ty + the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers in returnDs (Lam old_s the_body) + +mkCCall :: Unique -> CCall + -> [CoreExpr] -- Args + -> Type -- Result type + -> CoreExpr +-- Construct the ccall. The only tricky bit is that the ccall Id should have +-- no free vars, so if any of the arg tys do we must give it a polymorphic type. +-- [I forget *why* it should have no free vars!] +-- For example: +-- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char] +-- +-- Here we build a ccall thus +-- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) +-- a b s x c +mkCCall uniq the_ccall val_args res_ty + = mkApps (mkVarApps (Var the_ccall_id) tyvars) val_args + where + arg_tys = map exprType val_args + body_ty = (mkFunTys arg_tys res_ty) + tyvars = varSetElems (tyVarsOfType body_ty) + ty = mkForAllTys tyvars body_ty + the_ccall_id = mkCCallOpId uniq the_ccall ty \end{code} \begin{code} @@ -144,7 +162,7 @@ unboxArg arg = newSysLocalDs arg_ty `thenDs` \ case_bndr -> newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[l_var, r_var, arr_cts_var] -> returnDs (Var arr_cts_var, - \ body -> Case arg case_bndr [(DataCon data_con,vars,body)] + \ body -> Case arg case_bndr [(DataAlt data_con,vars,body)] ) -- Data types with a single constructor, which has a single, primitive-typed arg @@ -152,14 +170,14 @@ unboxArg arg = newSysLocalDs arg_ty `thenDs` \ case_bndr -> newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg -> returnDs (Var prim_arg, - \ body -> Case arg case_bndr [(DataCon box_data_con,[prim_arg],body)] + \ body -> Case arg case_bndr [(DataAlt box_data_con,[prim_arg],body)] ) | otherwise = getSrcLocDs `thenDs` \ l -> pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) where - arg_ty = coreExprType arg + arg_ty = exprType arg maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty @@ -203,8 +221,8 @@ boxResult result_ty the_pair = mkConApp unboxedPairDataCon [Type realWorldStatePrimTy, Type result_ty, Var prim_state_id, - Con (DataCon unitDataCon) []] - the_alt = (DataCon (unboxedTupleCon 1), [prim_state_id], the_pair) + Var unitDataConId] + the_alt = (DataAlt (unboxedTupleCon 1), [prim_state_id], the_pair) scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy] in returnDs (scrut_ty, \prim_app -> Case prim_app (mkWildId scrut_ty) [the_alt] @@ -224,7 +242,7 @@ boxResult result_ty the_pair = mkConApp unboxedPairDataCon [Type realWorldStatePrimTy, Type result_ty, Var prim_state_id, the_result] - the_alt = (DataCon unboxedPairDataCon, [prim_state_id, prim_result_id], the_pair) + the_alt = (DataAlt unboxedPairDataCon, [prim_state_id, prim_result_id], the_pair) in returnDs (ccall_res_type, \prim_app -> Case prim_app case_bndr [the_alt] ) @@ -255,10 +273,10 @@ wrapUnboxedValue ty | (maybeToBool maybe_product_type) && -- Data type (null data_con_arg_tys) = - let unit = dataConId unitDataCon + let scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy] in - returnDs (scrut_ty, unit, mkConApp unitDataCon []) + returnDs (scrut_ty, unitDataConId, Var unitDataConId) | otherwise = pprPanic "boxResult: " (ppr ty) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index bce1b1da9f..70e548940c 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -29,28 +29,32 @@ import DsListComp ( dsListComp ) import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr ) import Match ( matchWrapper, matchSimply ) -import CoreUtils ( coreExprType ) +import CoreUtils ( exprType ) import CostCentre ( mkUserCC ) import FieldLabel ( FieldLabel ) import Id ( Id, idType, recordSelectorFieldLabel ) -import Const ( Con(..) ) import DataCon ( DataCon, dataConId, dataConTyCon, dataConArgTys, dataConFieldLabels ) -import Const ( mkMachInt, Literal(..), mkStrLit ) -import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID ) +import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, addr2IntegerId ) import TyCon ( isNewTyCon ) import DataCon ( isExistentialDataCon ) +import Literal ( Literal(..), inIntRange ) import Type ( splitFunTys, mkTyConApp, - splitAlgTyConApp, splitTyConApp_maybe, isNotUsgTy, unUsgTy, + splitAlgTyConApp, splitAlgTyConApp_maybe, splitTyConApp_maybe, + isNotUsgTy, unUsgTy, splitAppTy, isUnLiftedType, Type ) import TysWiredIn ( tupleCon, unboxedTupleCon, listTyCon, mkListTy, - charDataCon, charTy, stringTy + charDataCon, charTy, stringTy, + smallIntegerDataCon, isIntegerTy ) import BasicTypes ( RecFlag(..) ) import Maybes ( maybeToBool ) +import Unique ( Uniquable(..), ratioTyConKey ) import Util ( zipEqual, zipWithEqual ) import Outputable + +import Ratio ( numerator, denominator ) \end{code} @@ -98,7 +102,7 @@ dsLet (MonoBind (AbsBinds [] [] binder_triples inlines `thenDs` \ error_expr -> matchSimply rhs PatBindMatch pat body' error_expr where - result_ty = coreExprType body + result_ty = exprType body -- Ordinary case for bindings dsLet (MonoBind binds sigs is_rec) body @@ -137,8 +141,6 @@ ToDo: put in range checks for when converting ``@i@'' For numeric literals, we try to detect there use at a standard type (@Int@, @Float@, etc.) are directly put in the right constructor. [NB: down with the @App@ conversion.] -Otherwise, we punt, putting in a @NoRep@ Core literal (where the -representation decisions are delayed)... See also below where we look for @DictApps@ for \tr{plusInt}, etc. @@ -158,9 +160,6 @@ dsExpr (HsLitOut (HsString s) _) -- "_" => build (\ c n -> c 'c' n) -- LATER --- otherwise, leave it as a NoRepStr; --- the Core-to-STG pass will wrap it in an application of "unpackCStringId". - dsExpr (HsLitOut (HsString str) _) = returnDs (mkStringLitFS str) @@ -190,22 +189,31 @@ dsExpr (HsLitOut (HsLitLit str) ty) (hcat [ptext str, text "; type: ", ppr ty]) dsExpr (HsLitOut (HsInt i) ty) - = returnDs (mkLit (NoRepInteger i ty)) + = returnDs (mkIntegerLit i) + dsExpr (HsLitOut (HsFrac r) ty) - = returnDs (mkLit (NoRepRational r ty)) + = returnDs (mkConApp ratio_data_con [Type integer_ty, + mkIntegerLit (numerator r), + mkIntegerLit (denominator r)]) + where + (ratio_data_con, integer_ty) + = case (splitAlgTyConApp_maybe ty) of + Just (tycon, [i_ty], [con]) + -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey) + (con, i_ty) + + _ -> (panic "ratio_data_con", panic "integer_ty") + + -- others where we know what to do: -dsExpr (HsLitOut (HsIntPrim i) _) - | (i >= toInteger minInt && i <= toInteger maxInt) - = returnDs (mkLit (mkMachInt i)) - | otherwise - = error ("ERROR: Int constant " ++ show i ++ out_of_range_msg) +dsExpr (HsLitOut (HsIntPrim i) _) + = returnDs (mkIntLit i) dsExpr (HsLitOut (HsFloatPrim f) _) = returnDs (mkLit (MachFloat f)) - -- ToDo: range checking needed! dsExpr (HsLitOut (HsDoublePrim d) _) = returnDs (mkLit (MachDouble d)) @@ -266,7 +274,7 @@ dsExpr (SectionL expr op) = dsExpr op `thenDs` \ core_op -> -- for the type of y, we need the type of op's 2nd argument let - (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op) + (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) in dsExpr expr `thenDs` \ x_core -> newSysLocalDs x_ty `thenDs` \ x_id -> @@ -280,7 +288,7 @@ dsExpr (SectionR op expr) = dsExpr op `thenDs` \ core_op -> -- for the type of x, we need the type of op's 2nd argument let - (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op) + (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) in dsExpr expr `thenDs` \ y_core -> newSysLocalDs x_ty `thenDs` \ x_id -> @@ -289,7 +297,7 @@ dsExpr (SectionR op expr) returnDs (bindNonRec y_id y_core $ Lam x_id (mkApps core_op [Var x_id, Var y_id])) -dsExpr (CCall lbl args may_gc is_asm result_ty) +dsExpr (HsCCall lbl args may_gc is_asm result_ty) = mapDs dsExpr args `thenDs` \ core_args -> dsCCall lbl core_args may_gc is_asm result_ty -- dsCCall does all the unboxification, etc. @@ -397,22 +405,9 @@ dsExpr (ExplicitTuple expr_list boxed) returnDs (mkConApp ((if boxed then tupleCon else unboxedTupleCon) (length expr_list)) - (map (Type . unUsgTy . coreExprType) core_exprs ++ core_exprs)) + (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs)) -- the above unUsgTy is *required* -- KSW 1999-04-07 -dsExpr (HsCon con_id [ty] [arg]) - | isNewTyCon tycon - = dsExpr arg `thenDs` \ arg' -> - returnDs (Note (Coerce result_ty (unUsgTy (coreExprType arg'))) arg') - where - result_ty = mkTyConApp tycon [ty] - tycon = dataConTyCon con_id - -dsExpr (HsCon con_id tys args) - = mapDs dsExpr args `thenDs` \ args2 -> - ASSERT( all isNotUsgTy tys ) - returnDs (mkConApp con_id (map Type tys ++ args2)) - dsExpr (ArithSeqOut expr (From from)) = dsExpr expr `thenDs` \ expr2 -> dsExpr from `thenDs` \ from2 -> @@ -463,7 +458,7 @@ constructor @C@, setting all of @C@'s fields to bottom. dsExpr (RecordConOut data_con con_expr rbinds) = dsExpr con_expr `thenDs` \ con_expr' -> let - (arg_tys, _) = splitFunTys (coreExprType con_expr') + (arg_tys, _) = splitFunTys (exprType con_expr') mk_arg (arg_ty, lbl) = case [rhs | (sel_id,rhs,_) <- rbinds, @@ -501,36 +496,29 @@ Then we translate as follows: other -> recUpdError "M.lhs/230" \end{verbatim} It's important that we use the constructor Ids for @T1@, @T2@ etc on the -RHSs, and do not generate a Core @Con@ directly, because the constructor +RHSs, and do not generate a Core constructor application directly, because the constructor might do some argument-evaluation first; and may have to throw away some dictionaries. \begin{code} dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds) - = dsExpr record_expr `thenDs` \ record_expr' -> + = getSrcLocDs `thenDs` \ src_loc -> + dsExpr record_expr `thenDs` \ record_expr' -> -- Desugar the rbinds, and generate let-bindings if -- necessary so that we don't lose sharing let - ds_rbind (sel_id, rhs, pun_flag) - = dsExpr rhs `thenDs` \ rhs' -> - returnDs (recordSelectorFieldLabel sel_id, rhs') - in - mapDs ds_rbind rbinds `thenDs` \ rbinds' -> - let - record_in_ty = coreExprType record_expr' + record_in_ty = exprType record_expr' (tycon, in_inst_tys, cons) = splitAlgTyConApp record_in_ty (_, out_inst_tys, _) = splitAlgTyConApp record_out_ty cons_to_upd = filter has_all_fields cons - -- initial_args are passed to every constructor - initial_args = map Type out_inst_tys ++ map Var dicts - mk_val_arg field old_arg_id - = case [rhs | (f, rhs) <- rbinds', field == f] of + = case [rhs | (sel_id, rhs, _) <- rbinds, + field == recordSelectorFieldLabel sel_id] of (rhs:rest) -> ASSERT(null rest) rhs - [] -> Var old_arg_id + [] -> HsVar old_arg_id mk_alt con = newSysLocalsDs (dataConArgTys con in_inst_tys) `thenDs` \ arg_ids -> @@ -538,25 +526,28 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds) let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg (dataConFieldLabels con) arg_ids - rhs = mkApps (mkApps (Var (dataConId con)) initial_args) val_args + rhs = foldl HsApp (DictApp (TyApp (HsVar (dataConId con)) + out_inst_tys) + dicts) + val_args in - returnDs (DataCon con, arg_ids, rhs) - - mk_default - | length cons_to_upd == length cons - = returnDs [] - | otherwise - = mkErrorAppDs rEC_UPD_ERROR_ID record_out_ty "" `thenDs` \ err -> - returnDs [(DEFAULT, [], err)] + returnDs (mkSimpleMatch [ConPat con record_in_ty [] [] (map VarPat arg_ids)] + rhs + (Just record_out_ty) + src_loc) in -- Record stuff doesn't work for existentials ASSERT( all (not . isExistentialDataCon) cons ) - newSysLocalDs record_in_ty `thenDs` \ case_bndr -> - mapDs mk_alt cons_to_upd `thenDs` \ alts -> - mk_default `thenDs` \ deflt -> + -- It's important to generate the match with matchWrapper, + -- and the right hand sides with applications of the wrapper Id + -- so that everything works when we are doing fancy unboxing on the + -- constructor aguments. + mapDs mk_alt cons_to_upd `thenDs` \ alts -> + matchWrapper RecUpdMatch alts "record update" `thenDs` \ ([discrim_var], matching_code) -> + + returnDs (bindNonRec discrim_var record_expr' matching_code) - returnDs (Case record_expr' case_bndr (alts ++ deflt)) where has_all_fields :: DataCon -> Bool has_all_fields con_id @@ -595,8 +586,6 @@ dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig" dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn" #endif -out_of_range_msg -- ditto - = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n" \end{code} %-------------------------------------------------------------------- @@ -629,12 +618,12 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty rest (App (App (Var fail_id) (Type b_ty)) - (mkLit (mkStrLit msg stringTy)))) + (mkStringLit msg))) go (ExprStmt expr locn : stmts) = do_expr expr locn `thenDs` \ expr2 -> let - (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) + (_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a) in if null stmts then returnDs expr2 @@ -652,7 +641,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty = putSrcLocDs locn $ dsExpr expr `thenDs` \ expr2 -> let - (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) + (_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a) fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) (HsLitOut (HsString (_PK_ msg)) stringTy) msg = ASSERT2( isNotUsgTy a_ty, ppr a_ty ) @@ -690,3 +679,13 @@ var_pat (VarPat _) = True var_pat _ = False \end{code} +\begin{code} +mkIntegerLit :: Integer -> CoreExpr +mkIntegerLit i + | inIntRange i -- Small enough, so start from an Int + = mkConApp smallIntegerDataCon [mkIntLit i] + + | otherwise -- Big, so start from a string + = App (Var addr2IntegerId) (Lit (MachStr (_PK_ (show i)))) +\end{code} + diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 4f4e285576..2766fa9b68 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -12,18 +12,19 @@ module DsForeign ( dsForeigns ) where import CoreSyn -import DsCCall ( dsCCall, boxResult, unboxArg, wrapUnboxedValue ) +import DsCCall ( dsCCall, mkCCall, boxResult, unboxArg, wrapUnboxedValue ) import DsMonad import DsUtils -import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic, ForKind(..) ) +import HsSyn ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) ) +import HsDecls ( extNameStatic ) import CallConv import TcHsSyn ( TypecheckedForeignDecl ) -import CoreUtils ( coreExprType ) -import Const ( Con(..), mkMachInt ) -import DataCon ( DataCon, dataConId ) +import CoreUtils ( exprType, mkInlineMe ) +import DataCon ( DataCon, dataConWrapId ) import Id ( Id, idType, idName, mkWildId, mkVanillaId ) -import Const ( Literal(..) ) +import MkId ( mkCCallOpId, mkWorkerId ) +import Literal ( Literal(..) ) import Module ( Module, moduleUserString ) import Name ( mkGlobalName, nameModule, nameOccName, getOccString, mkForeignExportOcc, isLocalName, @@ -35,13 +36,14 @@ import Type ( splitAlgTyConApp_maybe, unUsgTy, Type, mkFunTys, mkForAllTys, mkTyConApp, mkTyVarTy, mkFunTy, splitAppTy ) -import PrimOp ( PrimOp(..) ) +import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import Var ( TyVar ) import TysPrim ( realWorldStatePrimTy, addrPrimTy ) import TysWiredIn ( unitTyCon, addrTy, stablePtrTyCon, unboxedTupleCon, addrDataCon ) import Unique +import Maybes ( maybeToBool ) import Outputable #if __GLASGOW_HASKELL__ >= 404 @@ -76,12 +78,12 @@ dsForeigns mod_name fos = foldlDs combine ([],[],empty,empty) fos where combine (acc_fi, acc_fe, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) | isForeignImport = -- foreign import (dynamic)? - dsFImport i (idType i) uns ext_nm cconv `thenDs` \ b -> - returnDs (b:acc_fi, acc_fe, acc_h, acc_c) + dsFImport i (idType i) uns ext_nm cconv `thenDs` \ bs -> + returnDs (bs ++ acc_fi, acc_fe, acc_h, acc_c) | isForeignLabel = dsFLabel i ext_nm `thenDs` \ b -> returnDs (b:acc_fi, acc_fe, acc_h, acc_c) - | isDynamic ext_nm = + | isDynamicExtName ext_nm = dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (fi,fe,h,c) -> returnDs (fi:acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c) @@ -107,90 +109,92 @@ Desugaring foreign imports is just the matter of creating a binding that on its RHS unboxes its arguments, performs the external call (using the @CCallOp@ primop), before boxing the result up and returning it. +However, we create a worker/wrapper pair, thus: + + foreign import f :: Int -> IO Int +==> + f x = IO ( \s -> case x of { I# x# -> + case fw s x# of { (# s1, y# #) -> + (# s1, I# y# #)}}) + + fw s x# = ccall f s x# + +The strictness/CPR analyser won't do this automatically because it doesn't look +inside returned tuples; but inlining this wrapper is a Really Good Idea +because it exposes the boxing to the call site. + + \begin{code} dsFImport :: Id -> Type -- Type of foreign import. -> Bool -- True <=> might cause Haskell GC -> ExtName -> CallConv - -> DsM CoreBind -dsFImport nm ty may_not_gc ext_name cconv = - newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s -> - splitForeignTyDs ty `thenDs` \ (tvs, args, mbIoDataCon, io_res_ty) -> - let - the_state_arg - | is_io_action = old_s - | otherwise = realWorldPrimId - - arg_exprs = map (Var) args - - is_io_action = - case mbIoDataCon of - Nothing -> False - _ -> True + -> DsM [CoreBind] +dsFImport fn_id ty may_not_gc ext_name cconv + = let + (tvs, arg_tys, mbIoDataCon, io_res_ty) = splitForeignTyDs ty + is_io_action = maybeToBool mbIoDataCon in - mapAndUnzipDs unboxArg arg_exprs `thenDs` \ (unboxed_args, arg_wrappers) -> + newSysLocalsDs arg_tys `thenDs` \ args -> + newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s -> + mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (unboxed_args, arg_wrappers) -> + (if not is_io_action then - newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok -> - wrapUnboxedValue io_res_ty `thenDs` \ (ccall_result_ty, v, res_v) -> + newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok -> + wrapUnboxedValue io_res_ty `thenDs` \ (ccall_result_ty, v, res_v) -> returnDs ( ccall_result_ty , \ prim_app -> Case prim_app (mkWildId ccall_result_ty) - [(DataCon (unboxedTupleCon 2), [state_tok, v], res_v)]) + [(DataAlt (unboxedTupleCon 2), [state_tok, v], res_v)]) else - boxResult io_res_ty) `thenDs` \ (final_result_ty, res_wrapper) -> + boxResult io_res_ty) `thenDs` \ (ccall_result_ty, res_wrapper) -> + (case ext_name of Dynamic -> getUniqueDs `thenDs` \ u -> - returnDs (Right u) - ExtName fs _ -> returnDs (Left fs)) `thenDs` \ lbl -> - let - val_args = Var the_state_arg : unboxed_args - final_args = Type inst_ty : val_args - - -- A CCallOp has type (forall a. a), so we must instantiate - -- it at the full type, including the state argument - inst_ty = mkFunTys (map coreExprType val_args) final_result_ty - - the_ccall_op = CCallOp lbl False (not may_not_gc) cconv - - the_prim_app = mkPrimApp the_ccall_op (final_args :: [CoreArg]) - - body = foldr ($) (res_wrapper the_prim_app) arg_wrappers + returnDs (DynamicTarget u) + ExtName fs _ -> returnDs (StaticTarget fs)) `thenDs` \ lbl -> - the_body - | not is_io_action = body - | otherwise = Lam old_s body - in - newSysLocalDs (coreExprType the_body) `thenDs` \ ds -> + getUniqueDs `thenDs` \ ccall_uniq -> + getUniqueDs `thenDs` \ work_uniq -> let - io_app = - case mbIoDataCon of - Nothing -> Var ds - Just ioDataCon -> - mkApps (Var (dataConId ioDataCon)) - [Type io_res_ty, Var ds] - - fo_rhs = mkLams (tvs ++ args) - (mkDsLet (NonRec ds (the_body::CoreExpr)) io_app) + the_state_arg | is_io_action = old_s + | otherwise = realWorldPrimId + + -- Build the worker + val_args = Var the_state_arg : unboxed_args + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty) + the_ccall = CCall lbl False (not may_not_gc) cconv + the_ccall_app = mkCCall ccall_uniq the_ccall val_args ccall_result_ty + work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) + work_id = mkWorkerId work_uniq fn_id worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers + io_app = case mbIoDataCon of + Nothing -> wrapper_body + Just ioDataCon -> mkApps (Var (dataConWrapId ioDataCon)) + [Type io_res_ty, Lam old_s wrapper_body] + wrap_rhs = mkInlineMe (mkLams (tvs ++ args) io_app) in - returnDs (NonRec nm fo_rhs) + returnDs [NonRec fn_id wrap_rhs, NonRec work_id work_rhs] \end{code} Given the type of a foreign import declaration, split it up into its constituent parts. \begin{code} -splitForeignTyDs :: Type -> DsM ([TyVar], [Id], Maybe DataCon, Type) -splitForeignTyDs ty = - newSysLocalsDs arg_tys `thenDs` \ ds_args -> - case splitAlgTyConApp_maybe res_ty of +splitForeignTyDs :: Type -> ([TyVar], [Type], Maybe DataCon, Type) +splitForeignTyDs ty + = case splitAlgTyConApp_maybe res_ty of Just (_,(io_res_ty:_),(ioCon:_)) -> -- .... -> IO t - returnDs (tvs, ds_args, Just ioCon, io_res_ty) + (tvs, arg_tys, Just ioCon, io_res_ty) _ -> -- .... -> t - returnDs (tvs, ds_args, Nothing, res_ty) + (tvs, arg_tys, Nothing, res_ty) where (arg_tys, res_ty) = splitFunTys sans_foralls (tvs, sans_foralls) = splitForAllTys ty - \end{code} foreign labels @@ -200,11 +204,7 @@ dsFLabel :: Id -> ExtName -> DsM CoreBind dsFLabel nm ext_name = returnDs (NonRec nm fo_rhs) where fo_rhs = mkConApp addrDataCon [mkLit (MachLitLit enm addrPrimTy)] - enm = - case ext_name of - ExtName f _ -> f - Dynamic -> panic "dsFLabel: Dynamic - shouldn't ever happen." - + enm = extNameStatic ext_name \end{code} The function that does most of the work for `@foreign export@' declarations. @@ -254,7 +254,7 @@ dsFExport i ty mod_name ext_name cconv isDyn = the_deref_app = mkApps (Var deRefStablePtrId) [ Type stbl_ptr_to_ty, Var stbl_ptr ] in - newSysLocalDs (coreExprType the_deref_app) `thenDs` \ x_deref_app -> + newSysLocalDs (exprType the_deref_app) `thenDs` \ x_deref_app -> dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId -> newSysLocalDs (mkFunTy stbl_ptr_to_ty (mkTyConApp ioTyCon [res_ty])) `thenDs` \ x_cont -> @@ -291,11 +291,7 @@ dsFExport i ty mod_name ext_name cconv isDyn = getUniqueDs `thenDs` \ uniq -> let the_body = mkLams (tvs ++ wrapper_args) the_app - - c_nm = - case ext_name of - ExtName fs _ -> fs - Dynamic -> panic "dsFExport: Dynamic - shouldn't ever happen." + c_nm = extNameStatic ext_name (h_stub, c_stub) = fexportEntry (moduleUserString mod) c_nm f_helper_glob @@ -390,7 +386,7 @@ dsFExportDynamic i ty mod_name ext_name cconv = dsLookupGlobalValue makeStablePtr_NAME `thenDs` \ makeStablePtrId -> let mk_stbl_ptr_app = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ] - mk_stbl_ptr_app_ty = coreExprType mk_stbl_ptr_app + mk_stbl_ptr_app_ty = exprType mk_stbl_ptr_app in newSysLocalDs mk_stbl_ptr_app_ty `thenDs` \ x_mk_stbl_ptr_app -> dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId -> @@ -413,7 +409,7 @@ dsFExportDynamic i ty mod_name ext_name cconv = to be entered using an external calling convention (stdcall, ccall). -} - adj_args = [ mkLit (mkMachInt (fromInt (callConvToInt cconv))) + adj_args = [ mkIntLitInt (callConvToInt cconv) , Var stbl_value , mkLit (MachLitLit (_PK_ fe_nm) addrPrimTy) ] @@ -422,7 +418,7 @@ dsFExportDynamic i ty mod_name ext_name cconv = adjustor = SLIT("createAdjustor") in dsCCall adjustor adj_args False False addrTy `thenDs` \ ccall_adj -> - let ccall_adj_ty = coreExprType ccall_adj + let ccall_adj_ty = exprType ccall_adj in newSysLocalDs ccall_adj_ty `thenDs` \ x_ccall_adj -> let ccall_io_adj = @@ -431,7 +427,7 @@ dsFExportDynamic i ty mod_name ext_name cconv = Note (Coerce (mkTyConApp ioTyCon [res_ty]) (unUsgTy ccall_adj_ty)) (Var x_ccall_adj) in - newSysLocalDs (coreExprType ccall_io_adj) `thenDs` \ x_ccall_io_adj -> + newSysLocalDs (exprType ccall_io_adj) `thenDs` \ x_ccall_io_adj -> let io_app = mkLams tvs $ mkLams [cback] $ stbl_app x_ccall_io_adj ccall_io_adj addrTy diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index 498ffcc4be..5149297bcb 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -18,7 +18,7 @@ import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy, unitTy ) import Panic ( panic ) \end{code} -Note: If @outPatType@ doesn't bear a strong resemblance to @coreExprType@, +Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@, then something is wrong. \begin{code} outPatType :: TypecheckedPat -> Type diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 6affb36cb1..fd38e6201f 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -19,10 +19,9 @@ import DsMonad -- the monadery used in the desugarer import DsUtils import CmdLineOpts ( opt_FoldrBuildOn ) -import CoreUtils ( coreExprType ) +import CoreUtils ( exprType ) import Id ( idType ) import Var ( Id, TyVar ) -import Const ( Con(..) ) import PrelInfo ( foldrId, buildId ) import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type ) import TysPrim ( alphaTyVar, alphaTy ) @@ -109,7 +108,7 @@ deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above = dsExpr expr `thenDs` \ core_expr -> - returnDs (mkConsExpr (coreExprType core_expr) core_expr list) + returnDs (mkConsExpr (exprType core_expr) core_expr list) deListComp (GuardStmt guard locn : quals) list -- rule B above = dsExpr guard `thenDs` \ core_guard -> @@ -124,12 +123,12 @@ deListComp (LetStmt binds : quals) list deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above = dsExpr list1 `thenDs` \ core_list1 -> let - u3_ty@u1_ty = coreExprType core_list1 -- two names, same thing + u3_ty@u1_ty = exprType core_list1 -- two names, same thing -- u1_ty is a [alpha] type, and u2_ty = alpha u2_ty = outPatType pat - res_ty = coreExprType core_list2 + res_ty = exprType core_list2 h_ty = u1_ty `mkFunTy` res_ty in newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] -> @@ -144,8 +143,8 @@ deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above rest_expr core_fail `thenDs` \ core_match -> let rhs = Lam u1 $ - Case (Var u1) u1 [(DataCon nilDataCon, [], core_list2), - (DataCon consDataCon, [u2, u3], core_match)] + Case (Var u1) u1 [(DataAlt nilDataCon, [], core_list2), + (DataAlt consDataCon, [u2, u3], core_match)] in returnDs (Let (Rec [(h, rhs)]) letrec_body) \end{code} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index edd9a2cfdf..b11166ac54 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -231,5 +231,6 @@ data DsMatchKind | DoBindMatch | ListCompMatch | LetMatch + | RecUpdMatch deriving () \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index d029aee446..81aaf42b53 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -38,10 +38,10 @@ import CoreSyn import DsMonad -import CoreUtils ( coreExprType ) +import CoreUtils ( exprType ) import PrelInfo ( iRREFUT_PAT_ERROR_ID ) import Id ( idType, Id, mkWildId ) -import Const ( Literal(..), Con(..) ) +import Literal ( Literal ) import TyCon ( isNewTyCon, tyConDataCons ) import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks, dataConId, splitProductType_maybe @@ -59,7 +59,7 @@ import TysPrim ( intPrimTy, import TysWiredIn ( nilDataCon, consDataCon, tupleCon, stringTy, - unitDataCon, unitTy, + unitDataConId, unitTy, charTy, charDataCon, intTy, intDataCon, floatTy, floatDataCon, @@ -271,7 +271,7 @@ mkCoPrimCaseMatchResult var match_alts returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)])) mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> - returnDs (Literal lit, [], body) + returnDs (LitAlt lit, [], body) mkCoAlgCaseMatchResult :: Id -- Scrutinee @@ -315,7 +315,7 @@ mkCoAlgCaseMatchResult var match_alts = body_fn fail `thenDs` \ body -> rebuildConArgs con args (dataConStrictMarks con) body `thenDs` \ (body', real_args) -> - returnDs (DataCon con, real_args, body') + returnDs (DataAlt con, real_args, body') mk_default fail | exhaustive_case = [] | otherwise = [(DEFAULT, [], fail)] @@ -349,7 +349,7 @@ rebuildConArgs con (arg:args) (str:stricts) body ASSERT( pack_con == pack_con1 ) newSysLocalsDs con_arg_tys `thenDs` \ unpacked_args -> returnDs ( - mkDsLet (NonRec arg (Con (DataCon pack_con) + mkDsLet (NonRec arg (mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args))) body', unpacked_args ++ real_args @@ -411,7 +411,7 @@ mkSelectorBinds (VarPat v) val_expr mkSelectorBinds pat val_expr | length binders == 1 || is_simple_pat pat - = newSysLocalDs (coreExprType val_expr) `thenDs` \ val_var -> + = newSysLocalDs (exprType val_expr) `thenDs` \ val_var -> -- For the error message we don't use mkErrorAppDs to avoid -- duplicating the string literal each time @@ -441,7 +441,7 @@ mkSelectorBinds pat val_expr where binders = collectTypedPatBinders pat local_tuple = mkTupleExpr binders - tuple_ty = coreExprType local_tuple + tuple_ty = exprType local_tuple mk_bind scrut_var msg_var bndr_var -- (mk_bind sv bv) generates @@ -473,7 +473,7 @@ throw out any usage annotation on the outside of an Id. \begin{code} mkTupleExpr :: [Id] -> CoreExpr -mkTupleExpr [] = mkConApp unitDataCon [] +mkTupleExpr [] = Var unitDataConId mkTupleExpr [id] = Var id mkTupleExpr ids = mkConApp (tupleCon (length ids)) (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ]) @@ -502,7 +502,7 @@ mkTupleSelector [var] should_be_the_same_var scrut_var scrut mkTupleSelector vars the_var scrut_var scrut = ASSERT( not (null vars) ) - Case scrut scrut_var [(DataCon (tupleCon (length vars)), vars, Var the_var)] + Case scrut scrut_var [(DataAlt (tupleCon (length vars)), vars, Var the_var)] \end{code} @@ -589,13 +589,13 @@ mkFailurePair expr = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var -> newSysLocalDs unitTy `thenDs` \ fail_fun_arg -> returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr), - App (Var fail_fun_var) (mkConApp unitDataCon [])) + App (Var fail_fun_var) (Var unitDataConId)) | otherwise = newFailLocalDs ty `thenDs` \ fail_var -> returnDs (NonRec fail_var expr, Var fail_var) where - ty = coreExprType expr + ty = exprType expr \end{code} diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index fcc65af8a1..91bfde287e 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -18,7 +18,6 @@ import TcHsSyn ( TypecheckedPat, TypecheckedMatch ) import DsHsSyn ( outPatType ) import Check ( check, ExhaustivePat ) import CoreSyn -import CoreUtils ( coreExprType ) import DsMonad import DsGRHSs ( dsGRHSs ) import DsUtils @@ -136,6 +135,12 @@ pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun , id ) + pp_match RecUpdMatch pats + = (hang (ptext SLIT("in a record-update construct")) + 4 (ppr_pats pats) + , id + ) + pp_match PatBindMatch pats = ( hang (ptext SLIT("in a pattern binding")) 4 (ppr_pats pats) @@ -172,6 +177,7 @@ separator (FunMatch _) = SLIT("=") separator (CaseMatch) = SLIT("->") separator (LambdaMatch) = SLIT("->") separator (PatBindMatch) = panic "When is this used?" +separator (RecUpdMatch) = panic "When is this used?" separator (DoBindMatch) = SLIT("<-") separator (ListCompMatch) = SLIT("<-") separator (LetMatch) = SLIT("=") @@ -185,7 +191,7 @@ ppr_incomplete_pats kind (pats,constraints) = sep (map ppr_constraint constraints)] -ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats] +ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats] ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats) \end{code} diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index af80397dc9..f3e10ff5c0 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -19,7 +19,7 @@ import Id ( Id ) import DsMonad import DsUtils -import Const ( mkMachInt, Literal(..) ) +import Literal ( mkMachInt, Literal(..) ) import PrimRep ( PrimRep(IntRep) ) import Maybes ( catMaybes ) import Type ( Type, isUnLiftedType ) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 60a2996f00..49dc3714b4 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -182,6 +182,7 @@ andMonoBindList binds loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs \end{code} + \begin{code} instance (Outputable id, Outputable pat) => Outputable (MonoBinds id pat) where @@ -261,7 +262,6 @@ data Sig name | DeprecSig (Deprecation name) -- DEPRECATED SrcLoc - data FixitySig name = FixitySig name Fixity SrcLoc -- We use exported entities for things to deprecate. Cunning trick (hack?): diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 71483119fb..1837027015 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -13,7 +13,7 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and \begin{code} module HsCore ( UfExpr(..), UfAlt, UfBinder(..), UfNote(..), - UfBinding(..), UfCon(..), + UfBinding(..), UfConAlt(..), HsIdInfo(..), HsStrictnessInfo(..), IfaceSig(..), UfRuleBody(..) ) where @@ -24,10 +24,11 @@ module HsCore ( import HsTypes ( HsType, pprParendHsType ) -- others: -import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo, CprInfo ) +import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo ) import CoreSyn ( CoreBndr, CoreExpr ) import Demand ( Demand ) -import Const ( Literal ) +import Literal ( Literal ) +import PrimOp ( CCall, pprCCallOp ) import Type ( Kind ) import CostCentre import SrcLoc ( SrcLoc ) @@ -44,30 +45,27 @@ import Outputable data UfExpr name = UfVar name | UfType (HsType name) - | UfCon (UfCon name) [UfExpr name] | UfTuple name [UfExpr name] -- Type arguments omitted | UfLam (UfBinder name) (UfExpr name) | UfApp (UfExpr name) (UfExpr name) | UfCase (UfExpr name) name [UfAlt name] | UfLet (UfBinding name) (UfExpr name) | UfNote (UfNote name) (UfExpr name) + | UfLit Literal + | UfLitLit FAST_STRING (HsType name) + | UfCCall CCall (HsType name) data UfNote name = UfSCC CostCentre | UfCoerce (HsType name) | UfInlineCall | UfInlineMe -type UfAlt name = (UfCon name, [name], UfExpr name) +type UfAlt name = (UfConAlt name, [name], UfExpr name) -data UfCon name = UfDefault - | UfDataCon name - | UfLitCon Literal - | UfLitLitCon FAST_STRING (HsType name) - | UfPrimOp name - | UfCCallOp FAST_STRING -- callee - Bool -- True => dynamic (first arg is fun. pointer) - Bool -- True <=> casm, rather than ccall - Bool -- True <=> might cause GC +data UfConAlt name = UfDefault + | UfDataAlt name + | UfLitAlt Literal + | UfLitLitAlt FAST_STRING (HsType name) data UfBinding name = UfNonRec (UfBinder name) @@ -89,10 +87,12 @@ data UfBinder name \begin{code} instance Outputable name => Outputable (UfExpr name) where ppr (UfVar v) = ppr v - ppr (UfType ty) = char '@' <+> pprParendHsType ty + ppr (UfLit l) = ppr l + + ppr (UfLitLit l ty) = ppr l + ppr (UfCCall cc ty) = pprCCallOp cc - ppr (UfCon c as) - = hsep [text "UfCon", ppr c, ppr as] + ppr (UfType ty) = char '@' <+> pprParendHsType ty ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as))) @@ -119,18 +119,11 @@ instance Outputable name => Outputable (UfExpr name) where ppr (UfNote note body) = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body] -instance Outputable name => Outputable (UfCon name) where +instance Outputable name => Outputable (UfConAlt name) where ppr UfDefault = text "DEFAULT" - ppr (UfLitCon l) = ppr l - ppr (UfLitLitCon l ty) = ppr l - ppr (UfDataCon d) = ppr d - ppr (UfPrimOp p) = ppr p - ppr (UfCCallOp str is_dyn is_casm can_gc) - = hcat [before, ptext str, after] - where - before = (if is_dyn then ptext SLIT("_dyn_") else empty) <> - ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ ")) - after = if is_casm then text "'' " else space + ppr (UfLitAlt l) = ppr l + ppr (UfLitLitAlt l ty) = ppr l + ppr (UfDataAlt d) = ppr d instance Outputable name => Outputable (UfBinder name) where ppr (UfValBinder name ty) = hsep [ppr name, dcolon, ppr ty] @@ -163,7 +156,7 @@ data HsIdInfo name | HsUpdate UpdateInfo | HsSpecialise (UfRuleBody name) | HsNoCafRefs - | HsCprInfo CprInfo + | HsCprInfo | HsWorker name -- Worker, if any instance Outputable name => Outputable (HsIdInfo name) where diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 822034a9e5..6b7b509651 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -10,7 +10,7 @@ Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@, module HsDecls ( HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..), DefaultDecl(..), ForeignDecl(..), ForKind(..), - ExtName(..), isDynamic, + ExtName(..), isDynamicExtName, extNameStatic, ConDecl(..), ConDetails(..), BangType(..), IfaceSig(..), SpecDataSig(..), hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls @@ -31,6 +31,7 @@ import Var ( TyVar ) -- others: import PprType import {-# SOURCE #-} FunDeps ( pprFundeps ) +import CStrings ( CLabelString ) import Outputable import SrcLoc ( SrcLoc ) import Util @@ -84,9 +85,9 @@ hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) #endif tyClDeclName :: TyClDecl name pat -> name -tyClDeclName (TyData _ _ name _ _ _ _ _) = name -tyClDeclName (TySynonym name _ _ _) = name -tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ _ _) = name +tyClDeclName (TyData _ _ name _ _ _ _ _) = name +tyClDeclName (TySynonym name _ _ _) = name +tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ _ _ _) = name \end{code} \begin{code} @@ -136,8 +137,9 @@ data TyClDecl name pat [Sig name] -- methods' signatures (MonoBinds name pat) -- default methods (ClassPragmas name) - name name [name] -- The names of the tycon, datacon, and superclass selectors - -- for this class. These are filled in as the ClassDecl is made. + name name name [name] -- The names of the tycon, datacon wrapper, datacon worker, + -- and superclass selectors for this class. + -- These are filled in as the ClassDecl is made. SrcLoc \end{code} @@ -145,10 +147,10 @@ data TyClDecl name pat countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int) -- class, data, newtype, synonym decls countTyClDecls decls - = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ _ _ <- decls], - length [() | TyData DataType _ _ _ _ _ _ _ <- decls], - length [() | TyData NewType _ _ _ _ _ _ _ <- decls], - length [() | TySynonym _ _ _ _ <- decls]) + = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ _ _ _ <- decls], + length [() | TyData DataType _ _ _ _ _ _ _ <- decls], + length [() | TyData NewType _ _ _ _ _ _ _ <- decls], + length [() | TySynonym _ _ _ _ <- decls]) isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool @@ -158,8 +160,8 @@ isSynDecl other = False isDataDecl (TyData _ _ _ _ _ _ _ _) = True isDataDecl other = False -isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _) = True -isClassDecl other = False +isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _ _) = True +isClassDecl other = False \end{code} \begin{code} @@ -180,7 +182,7 @@ instance (Outputable name, Outputable pat) NewType -> SLIT("newtype") DataType -> SLIT("data") - ppr (ClassDecl context clas tyvars fds sigs methods pragmas _ _ _ src_loc) + ppr (ClassDecl context clas tyvars fds sigs methods pragmas _ _ _ _ src_loc) | null sigs -- No "where" part = top_matter @@ -236,7 +238,11 @@ instance (Outputable name) \begin{code} data ConDecl name - = ConDecl name -- Constructor name + = ConDecl name -- Constructor name; this is used for the + -- DataCon itself, and for the user-callable wrapper Id + + name -- Name of the constructor's 'worker Id' + -- Filled in as the ConDecl is built [HsTyVar name] -- Existentially quantified type variables (HsContext name) -- ...and context @@ -268,7 +274,7 @@ data BangType name \begin{code} instance (Outputable name) => Outputable (ConDecl name) where - ppr (ConDecl con tvs cxt con_details loc) + ppr (ConDecl con _ tvs cxt con_details loc) = sep [pprForAll tvs, pprHsContext cxt, ppr_con_details con con_details] ppr_con_details con (InfixCon ty1 ty2) @@ -394,11 +400,18 @@ data ForKind data ExtName = Dynamic - | ExtName FAST_STRING (Maybe FAST_STRING) - -isDynamic :: ExtName -> Bool -isDynamic Dynamic = True -isDynamic _ = False + | ExtName CLabelString -- The external name of the foreign thing, + (Maybe CLabelString) -- and optionally its DLL or module name + -- Both of these are completely unencoded; + -- we just print them as they are + +isDynamicExtName :: ExtName -> Bool +isDynamicExtName Dynamic = True +isDynamicExtName _ = False + +extNameStatic :: ExtName -> CLabelString +extNameStatic (ExtName f _) = f +extNameStatic Dynamic = panic "staticExtName: Dynamic - shouldn't ever happen." instance Outputable ExtName where diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index ba980eed74..356b4608d7 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -108,9 +108,6 @@ data HsExpr id pat -- direct from the components Bool -- boxed? - | HsCon DataCon -- TRANSLATION; a saturated constructor application - [Type] - [HsExpr id pat] -- Record construction | RecordCon id -- The constructor @@ -126,9 +123,9 @@ data HsExpr id pat (HsRecordBinds id pat) | RecordUpdOut (HsExpr id pat) -- TRANSLATION - Type -- Type of *result* record (may differ from + Type -- Type of *result* record (may differ from -- type of input record) - [id] -- Dicts needed for construction + [id] -- Dicts needed for construction (HsRecordBinds id pat) | ExprWithTySig -- signature binding @@ -140,7 +137,7 @@ data HsExpr id pat (HsExpr id pat) -- (typechecked, of course) (ArithSeqInfo id pat) - | CCall FAST_STRING -- call into the C world; string is + | HsCCall FAST_STRING -- call into the C world; string is [HsExpr id pat] -- the C function; exprs are the -- arguments to pass. Bool -- True <=> might cause Haskell @@ -315,10 +312,6 @@ ppr_expr (ExplicitTuple exprs True) ppr_expr (ExplicitTuple exprs False) = ptext SLIT("(#") <> sep (punctuate comma (map ppr_expr exprs)) <> ptext SLIT("#)") -ppr_expr (HsCon con_id tys args) - = ppr con_id <+> sep (map pprParendType tys ++ - map pprParendExpr args) - ppr_expr (RecordCon con_id rbinds) = pp_rbinds (ppr con_id) rbinds ppr_expr (RecordConOut data_con con rbinds) @@ -342,7 +335,7 @@ ppr_expr EWildPat = char '_' ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e -ppr_expr (CCall fun args _ is_asm result_ty) +ppr_expr (HsCCall fun args _ is_asm result_ty) = hang (if is_asm then ptext SLIT("_casm_ ``") <> ptext fun <> ptext SLIT("''") else ptext SLIT("_ccall_") <+> ptext fun) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index ed37ca63b2..5594ece579 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -116,7 +116,6 @@ module CmdLineOpts ( opt_UF_KeenessFactor, opt_UF_CheapOp, opt_UF_DearOp, - opt_UF_NoRepLit, -- misc opts opt_CompilingPrelude, @@ -207,7 +206,7 @@ data CoreToDo -- These are diff core-to-core passes, -- Each run of the simplifier can take a different -- set of simplifier-specific flags. | CoreDoFloatInwards - | CoreDoFullLaziness + | CoreDoFloatOutwards Bool -- True <=> float lambdas to top level | CoreLiberateCase | CoreDoPrintCore | CoreDoStaticArgs @@ -235,6 +234,7 @@ data SimplifierSwitch = MaxSimplifierIterations Int | SimplInlinePhase Int | DontApplyRules + | NoCaseOfCase | SimplLetToCase \end{code} @@ -426,17 +426,16 @@ opt_SimplCaseMerge = lookUp SLIT("-fcase-merge") opt_SimplPedanticBottoms = lookUp SLIT("-fpedantic-bottoms") -- Unfolding control -opt_UF_HiFileThreshold = lookup_def_int "-funfolding-interface-threshold" (30::Int) -opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (30::Int) +opt_UF_HiFileThreshold = lookup_def_int "-funfolding-interface-threshold" (45::Int) +opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int) opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (8::Int) -- Discounts can be big opt_UF_ScrutConDiscount = lookup_def_int "-funfolding-con-discount" (2::Int) opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn opt_UF_PrimArgDiscount = lookup_def_int "-funfolding-prim-discount" (1::Int) -opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (2.0::Float) +opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.0::Float) -opt_UF_CheapOp = ( 0 :: Int) -- Only one instruction; and the args are charged for +opt_UF_CheapOp = ( 1 :: Int) -- Only one instruction; and the args are charged for opt_UF_DearOp = ( 4 :: Int) -opt_UF_NoRepLit = ( 20 :: Int) -- Strings can be pretty big opt_ProduceS = lookup_str "-S=" opt_ReportCompile = lookUp SLIT("-freport-compile") @@ -480,7 +479,8 @@ classifyOpts = sep argv [] [] -- accumulators... simpl_sep opts defaultSimplSwitches core_td stg_td "-ffloat-inwards" -> CORE_TD(CoreDoFloatInwards) - "-ffull-laziness" -> CORE_TD(CoreDoFullLaziness) + "-ffloat-outwards" -> CORE_TD(CoreDoFloatOutwards False) + "-ffloat-outwards-full" -> CORE_TD(CoreDoFloatOutwards True) "-fliberate-case" -> CORE_TD(CoreLiberateCase) "-fcse" -> CORE_TD(CoreCSE) "-fprint-core" -> CORE_TD(CoreDoPrintCore) @@ -533,6 +533,7 @@ matchSimplSw opt = firstJust [ matchSwInt opt "-fmax-simplifier-iterations" MaxSimplifierIterations , matchSwInt opt "-finline-phase" SimplInlinePhase , matchSwBool opt "-fno-rules" DontApplyRules + , matchSwBool opt "-fno-case-of-case" NoCaseOfCase , matchSwBool opt "-flet-to-case" SimplLetToCase ] @@ -568,10 +569,11 @@ tagOf_SimplSwitch (SimplInlinePhase _) = ILIT(1) tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(2) tagOf_SimplSwitch DontApplyRules = ILIT(3) tagOf_SimplSwitch SimplLetToCase = ILIT(4) +tagOf_SimplSwitch NoCaseOfCase = ILIT(5) -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! -lAST_SIMPL_SWITCH_TAG = 4 +lAST_SIMPL_SWITCH_TAG = 5 \end{code} %************************************************************************ diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index e7fb411a48..47f3b36762 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -8,10 +8,17 @@ module CodeOutput( codeOutput ) where #include "HsVersions.h" -#if ! OMIT_NATIVE_CODEGEN +#ifndef OMIT_NATIVE_CODEGEN import AsmCodeGen ( nativeCodeGen ) #endif +#ifdef ILX +import IlxGen ( ilxGen ) +#endif +import TyCon ( TyCon ) +import Id ( Id ) +import Class ( Class ) +import StgSyn ( StgBinding ) import AbsCSyn ( AbstractC, absCNop ) import PprAbsC ( dumpRealC, writeRealC ) import UniqSupply ( UniqSupply ) @@ -20,28 +27,39 @@ import CmdLineOpts import Maybes ( maybeToBool ) import ErrUtils ( doIfSet, dumpIfSet ) import Outputable -import IO ( IOMode(..), hPutStr, hClose, openFile, stderr ) +import IO ( IOMode(..), hPutStr, hClose, openFile ) \end{code} \begin{code} codeOutput :: Module + -> [TyCon] -> [Class] -- Local tycons and classes + -> [(StgBinding,[Id])] -- The STG program with SRTs -> SDoc -- C stubs for foreign exported functions -> SDoc -- Header file prototype for foreign exported functions -> AbstractC -- Compiled abstract C -> UniqSupply -> IO () -codeOutput mod_name c_code h_code flat_abstractC ncg_uniqs +codeOutput mod_name tycons classes stg_binds c_code h_code flat_abstractC ncg_uniqs = -- You can have C (c_output) or assembly-language (ncg_output), -- but not both. [Allowing for both gives a space leak on -- flat_abstractC. WDP 94/10] - dumpIfSet opt_D_dump_stix "Final stix code" stix_final >> - - dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d >> - doOutput opt_ProduceS ncg_output_w >> +#ifndef OMIT_NATIVE_CODEGEN + let + (stix_final, ncg_output_d) = nativeCodeGen flat_absC_ncg ncg_uniqs + ncg_output_w = (\ f -> printForUser f ncg_output_d) + in + dumpIfSet opt_D_dump_stix "Final stix code" stix_final >> + dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d >> + doOutput opt_ProduceS ncg_output_w >> +#else +#ifdef ILX + doOutput opt_ProduceS (\f -> printForUser f (ilxGen tycons stg_binds)) >> +#endif +#endif - dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d >> + dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d >> outputForeignStubs True{-.h output-} opt_ProduceExportHStubs stub_h_output_w >> dumpIfSet opt_D_dump_foreign "Foreign export stubs" stub_c_output_d >> @@ -70,16 +88,6 @@ codeOutput mod_name c_code h_code flat_abstractC ncg_uniqs c_output_d = dumpRealC flat_absC_c c_output_w = (\ f -> writeRealC f flat_absC_c) - -- Native code generation done here! -#if OMIT_NATIVE_CODEGEN - ncg_output_d = error "*** GHC not built with a native-code generator ***" - ncg_output_w = ncg_output_d -#else - (stix_final, ncg_output_d) - = nativeCodeGen flat_absC_ncg ncg_uniqs - ncg_output_w = (\ f -> printForAsm f ncg_output_d) -#endif - -- don't use doOutput for dumping the f. export stubs -- since it is more than likely that the stubs file will diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs index 53495daf8a..f67e00707c 100644 --- a/ghc/compiler/main/Constants.lhs +++ b/ghc/compiler/main/Constants.lhs @@ -14,8 +14,6 @@ module Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE, - tARGET_MIN_INT, tARGET_MAX_INT, - mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject, @@ -106,22 +104,6 @@ mIN_UPD_SIZE = (MIN_UPD_SIZE::Int) mIN_SIZE_NonUpdHeapObject = (MIN_NONUPD_SIZE::Int) \end{code} -If we're compiling with GHC (and we're not cross-compiling), then we -know that minBound and maxBound :: Int are the right values for the -target architecture. Otherwise, we assume -2^31 and 2^31-1 -respectively (which will be wrong on a 64-bit machine). - -\begin{code} -tARGET_MIN_INT, tARGET_MAX_INT :: Integer -#if __GLASGOW_HASKELL__ -tARGET_MIN_INT = toInteger (minBound :: Int) -tARGET_MAX_INT = toInteger (maxBound :: Int) -#else -tARGET_MIN_INT = -2147483648 -tARGET_MAX_INT = 2147483647 -#endif -\end{code} - Constants for semi-tagging; the tags associated with the data constructors will start at 0 and go up. diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 5eea51b73b..f88af6a65a 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -157,11 +157,11 @@ doIt (core_cmds, stg_cmds) -------------------------- Main Core-language transformations ---------------- _scc_ "Core2Core" - core2core core_cmds desugared rules >>= \ (simplified, imp_rule_ids) -> + core2core core_cmds desugared rules >>= \ (simplified, orphan_rules) -> -- Do the final tidy-up tidyCorePgm tidy_uniqs this_mod - simplified imp_rule_ids >>= \ (tidy_binds, tidy_imp_rule_ids) -> + simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) -> -------------------------- Convert to STG code ------------------------------- @@ -189,7 +189,7 @@ doIt (core_cmds, stg_cmds) -- thoroughout code generation ifaceDecls if_handle local_tycons local_classes inst_info - final_ids tidy_binds imp_rule_ids deprecations >> + final_ids tidy_binds tidy_orphan_rules deprecations >> endIface if_handle >> -- We are definitely done w/ interface-file stuff at this point: -- (See comments near call to "startIface".) @@ -208,7 +208,9 @@ doIt (core_cmds, stg_cmds) -------------------------- Code output ------------------------------- show_pass "CodeOutput" >> _scc_ "CodeOutput" - codeOutput this_mod c_code h_code abstractC ncg_uniqs >> + codeOutput this_mod local_tycons local_classes stg_binds2 + c_code h_code abstractC + ncg_uniqs >> -------------------------- Final report ------------------------------- @@ -332,7 +334,7 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds}) data_info other = (0,0) - class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ _ _) + class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ _ _ _) = case count_sigs meth_sigs of (_,classops,_,_) -> (classops, addpr (count_monobinds def_meths)) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index db046532a3..685176523f 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -22,7 +22,7 @@ import TcInstUtil ( InstInfo(..) ) import CmdLineOpts import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, - getIdSpecialisation + idSpecialisation ) import Var ( isId ) import VarSet @@ -33,11 +33,11 @@ import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo, InlinePragInfo(..), inli cafInfo, ppCafInfo, specInfo, cprInfo, ppCprInfo, pprInlinePragInfo, occInfo, OccInfo(..), - workerExists, workerInfo, ppWorkerInfo + workerExists, workerInfo, ppWorkerInfo, WorkerInfo(..) ) import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars ) import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) -import CoreUnfold ( calcUnfoldingGuidance, okToUnfoldInHiFile, couldBeSmallEnoughToInline ) +import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline ) import Module ( moduleString, pprModule, pprModuleName ) import Name ( isLocallyDefined, isWiredInName, nameRdrName, nameModule, Name, NamedThing(..) @@ -214,7 +214,9 @@ ifaceFixities if_hdl fixities ifaceRules :: Handle -> [ProtoCoreRule] -> IdSet -> IO () ifaceRules if_hdl rules emitted - | null orphan_rule_pretties && null local_id_pretties + | opt_OmitInterfacePragmas -- Don't emit rules if we are suppressing + -- interface pragmas + || (null orphan_rule_pretties && null local_id_pretties) = return () | otherwise = printForIface if_hdl (vcat [ @@ -229,9 +231,10 @@ ifaceRules if_hdl rules emitted ] local_id_pretties = [ pprCoreRule (Just fn) rule | fn <- varSetElems emitted, - rule <- rulesRules (getIdSpecialisation fn), + rule <- rulesRules (idSpecialisation fn), all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) -- Spit out a rule only if all its lhs free vars are emitted + -- This is a good reason not to do it when we emit the Id itself ] ifaceDeprecations :: Handle -> [Deprecation Name] -> IO () @@ -359,7 +362,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs work_info = workerInfo core_idinfo has_worker = workerExists work_info wrkr_pretty = ppWorkerInfo work_info - Just work_id = work_info + HasWorker work_id wrap_arity = work_info ------------ Occ info -------------- @@ -384,7 +387,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs rhs_is_small && -- Small enough okToUnfoldInHiFile rhs -- No casms etc - rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs) + rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs ------------ Specialisations -------------- spec_info = specInfo core_idinfo @@ -410,12 +413,8 @@ ifaceId get_idinfo needed_ids is_rec id rhs ------------ Sanity checking -------------- -- The arity of a wrapper function should match its strictness, -- or else an importing module will get very confused indeed. - -- [later: actually all that is necessary is for strictness to exceed arity] - arity_matches_strictness - = not has_worker || - case strict_info of - StrictnessInfo ds _ -> length ds >= arityLowerBound arity_info - other -> True + arity_matches_strictness = not has_worker || + wrap_arity == arityLowerBound arity_info interestingId id = isId id && isLocallyDefined id && not (omitIfaceSigForId id) diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index c918451506..5a73c8fe2c 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -23,13 +23,13 @@ import SMRep ( fixedItblSize, ) import Constants ( mIN_UPD_SIZE ) import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel, - mkClosureTblLabel, mkStaticClosureLabel, + mkClosureTblLabel, mkClosureLabel moduleRegdLabel ) import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI, closureUpdReqd, staticClosureNeedsLink ) -import Const ( Literal(..) ) +import Literal ( Literal(..) ) import Maybes ( maybeToBool ) import PrimOp ( primOpNeedsWrapper, PrimOp(..) ) import PrimRep ( isFloatingRep, PrimRep(..) ) @@ -41,6 +41,7 @@ import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) import Util ( naturalMergeSortLe ) import Panic ( panic ) import TyCon ( tyConDataCons ) +import DataCon ( dataConWrapId ) import BitSet ( intBS ) import Name ( NamedThing(..) ) @@ -147,7 +148,7 @@ Here we handle top-level things, like @CCodeBlock@s and gentopcode stmt@(CClosureTbl tycon) = returnUs [ StSegment TextSegment , StLabel (mkClosureTblLabel tycon) - , StData DataPtrRep (map (StCLbl . mkStaticClosureLabel . getName) + , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId) (tyConDataCons tycon) ) ] @@ -391,8 +392,8 @@ Now the if statement. Almost *all* flow of control are of this form. Nothing -> gencode alt_code Just dc -> mkIfThenElse discrim tag alt_code dc - [(tag1@(MachInt i1 _), alt_code1), - (tag2@(MachInt i2 _), alt_code2)] + [(tag1@(MachInt i1), alt_code1), + (tag2@(MachInt i2), alt_code2)] | deflt_is_empty && i1 == 0 && i2 == 1 -> mkIfThenElse discrim tag1 alt_code1 alt_code2 | deflt_is_empty && i1 == 1 && i2 == 0 @@ -448,7 +449,7 @@ be tuned.) intTag :: Literal -> Integer intTag (MachChar c) = toInteger (ord c) - intTag (MachInt i _) = i + intTag (MachInt i) = i intTag _ = panic "intTag" fltTag :: Literal -> Rational @@ -492,9 +493,9 @@ be tuned.) floating = isFloatingRep (getAmodeRep am) choices = length alts - (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y - (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y - (x,_) `leAlt` (y,_) = fltTag x <= fltTag y + (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y + (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y + (x,_) `leAlt` (y,_) = fltTag x <= fltTag y \end{code} diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index c1eb86973c..db78cb446e 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -43,7 +43,7 @@ module MachMisc ( import AbsCSyn ( MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) import CLabel ( CLabel, isAsmTemp ) -import Const ( mkMachInt, Literal(..) ) +import Literal ( mkMachInt, Literal(..) ) import MachRegs ( stgReg, callerSaves, RegLoc(..), Imm(..), Reg(..), MachRegsAddr(..) diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index abd7306b15..8748879688 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -18,7 +18,7 @@ import MachMisc import MachRegs import AbsCSyn hiding (spRel) -- bits and bobs.. -import Const ( Literal(..) ) +import Literal ( Literal(..) ) import CallConv ( cCallConv ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index e718379557..26d7bd1a2f 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -16,9 +16,9 @@ import AbsCSyn hiding ( spRel ) import AbsCUtils ( getAmodeRep, mixedTypeLocn ) import Constants ( uF_UPDATEE ) import SMRep ( fixedHdrSize ) -import Const ( Literal(..) ) +import Literal ( Literal(..) ) import CallConv ( cCallConv ) -import PrimOp ( PrimOp(..) ) +import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import PrimRep ( PrimRep(..), isFloatingRep ) import UniqSupply ( returnUs, thenUs, UniqSM ) import Constants ( mIN_INTLIKE ) @@ -213,7 +213,7 @@ primCode [] (WriteByteArrayOp pk) [obj, ix, v] \begin{code} --primCode lhs (CCallOp fn is_asm may_gc) rhs -primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs +primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs | is_asm = error "ERROR: Native code generator can't handle casm" | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n" | otherwise @@ -377,7 +377,7 @@ amodeToStix (CCharLike x) where off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)] -amodeToStix (CIntLike (CLit (MachInt i _))) +amodeToStix (CIntLike (CLit (MachInt i))) = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off)) where off = intLikeSize * (fromInteger (i - mIN_INTLIKE)) @@ -390,7 +390,7 @@ amodeToStix (CLit core) MachChar c -> StInt (toInteger (ord c)) MachStr s -> StString s MachAddr a -> StInt a - MachInt i _ -> StInt (toInteger i) + MachInt i -> StInt (toInteger i) MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (litLitToStix (_UNPK_ s)) MachFloat d -> StDouble d MachDouble d -> StDouble d diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 6b1e21242c..ab4bf3c7bb 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -145,6 +145,9 @@ data Token | ITbottom | ITinteger_lit | ITfloat_lit + | ITword_lit + | ITword64_lit + | ITint64_lit | ITrational_lit | ITaddr_lit | ITlit_lit @@ -158,8 +161,8 @@ data Token | ITunfold InlinePragInfo | ITstrict ([Demand], Bool) | ITrules + | ITcprinfo | ITdeprecated - | ITcprinfo (CprInfo) | IT__scc | ITsccAllCafs @@ -311,6 +314,9 @@ ghcExtensionKeywordsFM = listToUFM $ ("__bot", ITbottom), ("__integer", ITinteger_lit), ("__float", ITfloat_lit), + ("__int64", ITint64_lit), + ("__word", ITword_lit), + ("__word64", ITword64_lit), ("__rational", ITrational_lit), ("__addr", ITaddr_lit), ("__litlit", ITlit_lit), @@ -574,8 +580,8 @@ lexToken cont glaexts buf = lex_demand cont (stepOnUntil (not . isSpace) (stepOnBy# buf 3#)) -- past __S 'M'# -> - lex_cpr cont (stepOnUntil (not . isSpace) - (stepOnBy# buf 3#)) -- past __M + cont ITcprinfo (stepOnBy# buf 3#) -- past __M + 's'# -> case prefixMatch (stepOnBy# buf 3#) "cc" of Just buf' -> lex_scc cont (stepOverLexeme buf') @@ -799,23 +805,6 @@ lex_demand cont buf = = case read_em [] buf of (stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest -lex_cpr cont buf = - case read_em [] buf of { (cpr_inf,buf') -> - ASSERT ( null (tail cpr_inf) ) - cont (ITcprinfo $ head cpr_inf) buf' - } - where - -- code snatched from lex_demand above - read_em acc buf = - case currentChar# buf of - '-'# -> read_em (NoCPRInfo : acc) (stepOn buf) - '('# -> do_unpack acc (stepOn buf) - ')'# -> (reverse acc, stepOn buf) - _ -> (reverse acc, buf) - - do_unpack acc buf - = case read_em [] buf of - (stuff, rest) -> read_em ((CPRInfo stuff) : acc) rest ------------------ lex_scc cont buf = diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index e26415e4d9..2372e4a769 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -25,6 +25,7 @@ module ParseUtil ( , checkPatterns -- [HsExp] -> P [HsPat] -- , checkExpr -- HsExp -> P HsExp , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl -- some built-in names (all :: RdrName) @@ -54,7 +55,7 @@ import RdrHsSyn import RdrName import CallConv import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr ) -import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameFS ) +import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameUserString ) import CmdLineOpts ( opt_NoImplicitPrelude ) import StringBuffer ( lexemeToString ) import FastString ( unpackFS ) @@ -318,17 +319,26 @@ checkValDef -> Maybe RdrNameHsType -> RdrNameGRHSs -> SrcLoc - -> P RdrNameMonoBinds + -> P RdrBinding checkValDef lhs opt_sig grhss loc = case isFunLhs lhs [] of Just (f,inf,es) -> checkPatterns es `thenP` \ps -> - returnP (FunMonoBind f inf [Match [] ps opt_sig grhss] loc) + returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc)) Nothing -> checkPattern lhs `thenP` \lhs -> - returnP (PatMonoBind lhs grhss loc) + returnP (RdrValBinding (PatMonoBind lhs grhss loc)) + +checkValSig + :: RdrNameHsExpr + -> RdrNameHsType + -> SrcLoc + -> P RdrBinding +checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc)) +checkValSig other ty loc = parseError "Type signature given for an expression" + -- A variable binding is parsed as an RdrNamePatBind. @@ -359,12 +369,15 @@ mkRecConstrOrUpdate exp fs@(_:_) mkRecConstrOrUpdate _ _ = parseError "Empty record update" --- supplying the ext_name in a foreign decl is optional ; if it +-- Supplying the ext_name in a foreign decl is optional ; if it -- isn't there, the Haskell name is assumed. Note that no transformation -- of the Haskell name is then performed, so if you foreign export (++), --- it's external name will be "++". Too bad. +-- it's external name will be "++". Too bad; it's important because we don't +-- want z-encoding (e.g. names with z's in them shouldn't be doubled) +-- (This is why we use occNameUserString.) mkExtName :: Maybe ExtName -> RdrName -> ExtName -mkExtName Nothing rdrNm = ExtName (occNameFS (rdrNameOcc rdrNm)) Nothing +mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm))) + Nothing mkExtName (Just x) _ = x ----------------------------------------------------------------------------- diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index bfb325789d..a1f02831e0 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.27 2000/03/02 22:51:30 lewie Exp $ +$Id: Parser.y,v 1.28 2000/03/23 17:45:22 simonpj Exp $ Haskell grammar. @@ -381,9 +381,8 @@ decls :: { [RdrBinding] } | {- empty -} { [] } decl :: { RdrBinding } - : signdecl { $1 } - | fixdecl { $1 } - | valdef { RdrValBinding $1 } + : fixdecl { $1 } + | valdef { $1 } | '{-# INLINE' srcloc opt_phase qvar '#-}' { RdrSig (InlineSig $4 $3 $2) } | '{-# NOINLINE' srcloc opt_phase qvar '#-}' { RdrSig (NoInlineSig $4 $3 $2) } | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}' @@ -422,29 +421,12 @@ fixdecl :: { RdrBinding } (Fixity $3 $2) $1)) | n <- $4 ] } -signdecl :: { RdrBinding } - : vars srcloc '::' sigtype { foldr1 RdrAndBindings - [ RdrSig (Sig n $4 $2) | n <- $1 ] } - sigtype :: { RdrNameHsType } - : ctype { mkHsForAllTy Nothing [] $1 } + : ctype { mkHsForAllTy Nothing [] $1 } -{- - ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var - instead of qvar, we get another shift/reduce-conflict. Consider the - following programs: - - { (+) :: ... } only var - { (+) x y = ... } could (incorrectly) be qvar - - We re-use expressions for patterns, so a qvar would be allowed in patterns - instead of a var only (which would be correct). But deciding what the + is, - would require more lookahead. So let's check for ourselves... --} - -vars :: { [RdrName] } - : vars ',' var { $3 : $1 } - | qvar { [ $1 ] } +sig_vars :: { [RdrName] } + : sig_vars ',' var { $3 : $1 } + | var { [ $1 ] } ----------------------------------------------------------------------------- -- Transformation Rules @@ -583,9 +565,9 @@ constrs :: { [RdrNameConDecl] } constr :: { RdrNameConDecl } : srcloc forall context constr_stuff - { ConDecl (fst $4) $2 $3 (snd $4) $1 } + { mkConDecl (fst $4) $2 $3 (snd $4) $1 } | srcloc forall constr_stuff - { ConDecl (fst $3) $2 [] (snd $3) $1 } + { mkConDecl (fst $3) $2 [] (snd $3) $1 } forall :: { [RdrNameHsTyVar] } : 'forall' tyvars '.' { $2 } @@ -600,9 +582,9 @@ constr_stuff :: { (RdrName, RdrNameConDetails) } | con '{' fielddecls '}' { ($1, RecCon (reverse $3)) } newconstr :: { RdrNameConDecl } - : srcloc conid atype { ConDecl $2 [] [] (NewCon $3 Nothing) $1 } + : srcloc conid atype { mkConDecl $2 [] [] (NewCon $3 Nothing) $1 } | srcloc conid '{' var '::' type '}' - { ConDecl $2 [] [] (NewCon $6 (Just $4)) $1 } + { mkConDecl $2 [] [] (NewCon $6 (Just $4)) $1 } scontype :: { (RdrName, [RdrNameBangType]) } : btype {% splitForConApp $1 [] } @@ -625,7 +607,7 @@ fielddecls :: { [([RdrName],RdrNameBangType)] } | fielddecl { [$1] } fielddecl :: { ([RdrName],RdrNameBangType) } - : vars '::' stype { (reverse $1, $3) } + : sig_vars '::' stype { (reverse $1, $3) } stype :: { RdrNameBangType } : ctype { Unbanged $1 } @@ -644,9 +626,32 @@ dclasses :: { [RdrName] } ----------------------------------------------------------------------------- -- Value definitions -valdef :: { RdrNameMonoBinds } - : infixexp {-ToDo: opt_sig-} srcloc rhs - {% checkValDef $1 Nothing $3 $2 } +{- There's an awkward overlap with a type signature. Consider + f :: Int -> Int = ...rhs... + Then we can't tell whether it's a type signature or a value + definition with a result signature until we see the '='. + So we have to inline enough to postpone reductions until we know. +-} + +{- + ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var + instead of qvar, we get another shift/reduce-conflict. Consider the + following programs: + + { (^^) :: Int->Int ; } Type signature; only var allowed + + { (^^) :: Int->Int = ... ; } Value defn with result signature; + qvar allowed (because of instance decls) + + We can't tell whether to reduce var to qvar until after we've read the signatures. +-} + +valdef :: { RdrBinding } + : infixexp srcloc opt_sig rhs {% checkValDef $1 $3 $4 $2 } + | infixexp srcloc '::' sigtype {% checkValSig $1 $4 $2 } + | var ',' sig_vars srcloc '::' sigtype { foldr1 RdrAndBindings + [ RdrSig (Sig n $6 $4) | n <- $1:$3 ] + } rhs :: { RdrNameGRHSs } : '=' srcloc exp wherebinds { GRHSs (unguardedRHS $3 $2) @@ -658,8 +663,7 @@ gdrhs :: { [RdrNameGRHS] } | gdrh { [$1] } gdrh :: { RdrNameGRHS } - : '|' srcloc quals '=' exp { GRHS (reverse - (ExprStmt $5 $2 : $3)) $2 } + : '|' srcloc quals '=' exp { GRHS (reverse (ExprStmt $5 $2 : $3)) $2 } ----------------------------------------------------------------------------- -- Expressions @@ -685,10 +689,10 @@ exp10 :: { RdrNameHsExpr } | '-' fexp { NegApp $2 (error "NegApp") } | srcloc 'do' stmtlist { HsDo DoStmt $3 $1 } - | '_ccall_' ccallid aexps0 { CCall $2 $3 False False cbot } - | '_ccall_GC_' ccallid aexps0 { CCall $2 $3 True False cbot } - | '_casm_' CLITLIT aexps0 { CCall $2 $3 False True cbot } - | '_casm_GC_' CLITLIT aexps0 { CCall $2 $3 True True cbot } + | '_ccall_' ccallid aexps0 { HsCCall $2 $3 False False cbot } + | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 True False cbot } + | '_casm_' CLITLIT aexps0 { HsCCall $2 $3 False True cbot } + | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 True True cbot } | '_scc_' STRING exp { if opt_SccProfilingOn then HsSCC $2 $3 @@ -795,7 +799,7 @@ alt :: { RdrNameMatch } opt_sig :: { Maybe RdrNameHsType } : {- empty -} { Nothing } - | '::' type { Just $2 } + | '::' sigtype { Just $2 } opt_asig :: { Maybe RdrNameHsType } : {- empty -} { Nothing } @@ -881,7 +885,11 @@ var :: { RdrName } qvar :: { RdrName } : qvarid { $1 } - | '(' qvarsym ')' { $2 } + | '(' varsym ')' { $2 } + | '(' qvarsym1 ')' { $2 } +-- We've inlined qvarsym here so that the decision about +-- whether it's a qvar or a var can be postponed until +-- *after* we see the close paren. ipvar :: { RdrName } : IPVARID { (mkSrcUnqual ipName (tailFS $1)) } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 41b9fdb0b4..4455fdba1e 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -53,7 +53,7 @@ module RdrHsSyn ( extractPatsTyVars, extractRuleBndrsTyVars, - mkOpApp, mkClassDecl, mkClassOpSig, + mkOpApp, mkClassDecl, mkClassOpSig, mkConDecl, cvBinds, cvMonoBindsAndSigs, @@ -65,7 +65,7 @@ module RdrHsSyn ( import HsSyn import Name ( mkClassTyConOcc, mkClassDataConOcc ) -import OccName ( mkClassTyConOcc, mkClassDataConOcc, +import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, mkSuperDictSelOcc, mkDefaultMethodOcc ) import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc ) @@ -202,15 +202,17 @@ tycon and datacon corresponding to the class, by deriving them from the name of the class itself. This saves recording the names in the interface file (which would be equally good). -Similarly for mkClassOpSig and default-method names. +Similarly for mkConDecl, mkClassOpSig and default-method names. \begin{code} mkClassDecl cxt cname tyvars fds sigs mbinds prags loc - = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname sc_sel_names loc + = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname dwname sc_sel_names loc where - cls_occ = rdrNameOcc cname - dname = mkRdrUnqual (mkClassDataConOcc cls_occ) - tname = mkRdrUnqual (mkClassTyConOcc cls_occ) + cls_occ = rdrNameOcc cname + data_occ = mkClassDataConOcc cls_occ + dname = mkRdrUnqual data_occ + dwname = mkRdrUnqual (mkWorkerOcc data_occ) + tname = mkRdrUnqual (mkClassTyConOcc cls_occ) sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ) | n <- [1..length cxt]] -- We number off the superclass selectors, 1, 2, 3 etc so that we @@ -225,6 +227,11 @@ mkClassOpSig has_default_method op ty loc = ClassOpSig op dm_rn has_default_method ty loc where dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op)) + +mkConDecl cname ex_vars cxt details loc + = ConDecl cname wkr_name ex_vars cxt details loc + where + wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname)) \end{code} A useful function for building @OpApps@. The operator is always a variable, diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 58a3d8fe2e..f049e0e412 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -64,7 +64,7 @@ import MkId -- Ditto import PrelMods -- Prelude module names import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName ) -import DataCon ( DataCon ) +import DataCon ( DataCon, dataConId, dataConWrapId ) import PrimRep ( PrimRep(..) ) import TysPrim -- TYPES import TysWiredIn @@ -108,7 +108,7 @@ builtinNames , listToBag (map getName wiredInIds) -- PrimOps - , listToBag (map (getName . mkPrimitiveId) allThePrimOps) + , listToBag (map (getName . mkPrimOpId) allThePrimOps) -- Thin-air ids , listToBag thinAirIdNames @@ -123,8 +123,11 @@ builtinNames getTyConNames :: TyCon -> Bag Name getTyConNames tycon = getName tycon `consBag` - listToBag (map getName (tyConDataCons tycon)) + unionManyBags (map get_data_con_names (tyConDataCons tycon)) -- Synonyms return empty list of constructors + where + get_data_con_names dc = listToBag [getName (dataConId dc), -- Worker + getName (dataConWrapId dc)] -- Wrapper \end{code} We let a lot of "non-standard" values be visible, so that we can make diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 081c4f108d..c22f57264a 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -14,12 +14,14 @@ module PrelRules ( primOpRule, builtinRules ) where import CoreSyn import Rules ( ProtoCoreRule(..) ) -import Id ( getIdUnfolding ) -import Const ( mkMachInt, mkMachWord, Literal(..), Con(..) ) +import Id ( idUnfolding, mkWildId, isDataConId_maybe ) +import Literal ( Literal(..), mkMachInt, mkMachWord, inIntRange, literalType, + word2IntLit, int2WordLit, int2CharLit, char2IntLit, int2FloatLit, int2DoubleLit + ) import PrimOp ( PrimOp(..), primOpOcc ) -import TysWiredIn ( trueDataCon, falseDataCon ) +import TysWiredIn ( trueDataConId, falseDataConId ) import TyCon ( tyConDataCons, isEnumerationTyCon, isNewTyCon ) -import DataCon ( dataConTag, dataConTyCon, fIRST_TAG ) +import DataCon ( DataCon, dataConTag, dataConRepArity, dataConTyCon, dataConId, fIRST_TAG ) import CoreUnfold ( maybeUnfoldingTemplate ) import CoreUtils ( exprIsValue, cheapEqExpr ) import Type ( splitTyConApp_maybe ) @@ -28,10 +30,6 @@ import ThinAir ( unpackCStringFoldrId ) import Maybes ( maybeToBool ) import Char ( ord, chr ) import Outputable - -#if __GLASGOW_HASKELL__ >= 404 -import GlaExts ( fromInt ) -#endif \end{code} @@ -53,11 +51,8 @@ primOpRule op primop_rule TagToEnumOp = tagToEnumRule primop_rule DataToTagOp = dataToTagRule - -- Addr operations - primop_rule Addr2IntOp = oneLit (addr2IntOp op_name) - -- Char operations - primop_rule OrdOp = oneLit (chrOp op_name) + primop_rule OrdOp = oneLit (litCoerce char2IntLit op_name) -- Int/Word operations primop_rule IntAddOp = twoLits (intOp2 (+) op_name) @@ -67,11 +62,11 @@ primOpRule op primop_rule IntRemOp = twoLits (intOp2Z rem op_name) primop_rule IntNegOp = oneLit (negOp op_name) - primop_rule ChrOp = oneLit (intCoerce (mkCharVal . chr) op_name) - primop_rule Int2FloatOp = oneLit (intCoerce mkFloatVal op_name) - primop_rule Int2DoubleOp = oneLit (intCoerce mkDoubleVal op_name) - primop_rule Word2IntOp = oneLit (intCoerce mkIntVal op_name) - primop_rule Int2WordOp = oneLit (intCoerce mkWordVal op_name) + primop_rule ChrOp = oneLit (litCoerce int2CharLit op_name) + primop_rule Int2FloatOp = oneLit (litCoerce int2FloatLit op_name) + primop_rule Int2DoubleOp = oneLit (litCoerce int2DoubleLit op_name) + primop_rule Word2IntOp = oneLit (litCoerce word2IntLit op_name) + primop_rule Int2WordOp = oneLit (litCoerce int2WordLit op_name) -- Float primop_rule FloatAddOp = twoLits (floatOp2 (+) op_name) @@ -87,43 +82,49 @@ primOpRule op primop_rule DoubleDivOp = twoLits (doubleOp2Z (/) op_name) -- Relational operators - primop_rule IntEqOp = relop (==) op_name `or_rule` litVar True op_name_case - primop_rule IntNeOp = relop (/=) op_name `or_rule` litVar False op_name_case - primop_rule CharEqOp = relop (==) op_name `or_rule` litVar True op_name_case - primop_rule CharNeOp = relop (/=) op_name `or_rule` litVar False op_name_case - - primop_rule IntGtOp = relop (>) op_name - primop_rule IntGeOp = relop (>=) op_name - primop_rule IntLeOp = relop (<=) op_name - primop_rule IntLtOp = relop (<) op_name - - primop_rule CharGtOp = relop (>) op_name - primop_rule CharGeOp = relop (>=) op_name - primop_rule CharLeOp = relop (<=) op_name - primop_rule CharLtOp = relop (<) op_name - - primop_rule FloatGtOp = relop (>) op_name - primop_rule FloatGeOp = relop (>=) op_name - primop_rule FloatLeOp = relop (<=) op_name - primop_rule FloatLtOp = relop (<) op_name - primop_rule FloatEqOp = relop (==) op_name - primop_rule FloatNeOp = relop (/=) op_name - - primop_rule DoubleGtOp = relop (>) op_name - primop_rule DoubleGeOp = relop (>=) op_name - primop_rule DoubleLeOp = relop (<=) op_name - primop_rule DoubleLtOp = relop (<) op_name - primop_rule DoubleEqOp = relop (==) op_name - primop_rule DoubleNeOp = relop (/=) op_name - - primop_rule WordGtOp = relop (>) op_name - primop_rule WordGeOp = relop (>=) op_name - primop_rule WordLeOp = relop (<=) op_name - primop_rule WordLtOp = relop (<) op_name - primop_rule WordEqOp = relop (==) op_name - primop_rule WordNeOp = relop (/=) op_name + primop_rule IntEqOp = relop (==) `or_rule` litEq True op_name_case + primop_rule IntNeOp = relop (/=) `or_rule` litEq False op_name_case + primop_rule CharEqOp = relop (==) `or_rule` litEq True op_name_case + primop_rule CharNeOp = relop (/=) `or_rule` litEq False op_name_case + + primop_rule IntGtOp = relop (>) + primop_rule IntGeOp = relop (>=) + primop_rule IntLeOp = relop (<=) + primop_rule IntLtOp = relop (<) + + primop_rule CharGtOp = relop (>) + primop_rule CharGeOp = relop (>=) + primop_rule CharLeOp = relop (<=) + primop_rule CharLtOp = relop (<) + + primop_rule FloatGtOp = relop (>) + primop_rule FloatGeOp = relop (>=) + primop_rule FloatLeOp = relop (<=) + primop_rule FloatLtOp = relop (<) + primop_rule FloatEqOp = relop (==) + primop_rule FloatNeOp = relop (/=) + + primop_rule DoubleGtOp = relop (>) + primop_rule DoubleGeOp = relop (>=) + primop_rule DoubleLeOp = relop (<=) + primop_rule DoubleLtOp = relop (<) + primop_rule DoubleEqOp = relop (==) + primop_rule DoubleNeOp = relop (/=) + + primop_rule WordGtOp = relop (>) + primop_rule WordGeOp = relop (>=) + primop_rule WordLeOp = relop (<=) + primop_rule WordLtOp = relop (<) + primop_rule WordEqOp = relop (==) + primop_rule WordNeOp = relop (/=) primop_rule other = \args -> Nothing + + + relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ) op_name) + -- Cunning. cmpOp compares the values to give an Ordering. + -- It applies its argument to that ordering value to turn + -- the ordering into a boolean value. (`cmp` EQ) is just the job. \end{code} %************************************************************************ @@ -132,59 +133,70 @@ primOpRule op %* * %************************************************************************ + IMPORTANT NOTE + +In all these operations we might find a LitLit as an operand; that's +why we have the catch-all Nothing case. + \begin{code} -------------------------- -intCoerce :: Num a => (a -> CoreExpr) -> RuleName -> Literal -> Maybe (RuleName, CoreExpr) -intCoerce fn name (MachInt i _) = Just (name, fn (fromInteger i)) +litCoerce :: (Literal -> Literal) -> RuleName -> Literal -> Maybe (RuleName, CoreExpr) +litCoerce fn name lit = Just (name, Lit (fn lit)) -------------------------- -relop cmp name = twoLits (\l1 l2 -> Just (name, if l1 `cmp` l2 then trueVal else falseVal)) +cmpOp :: (Ordering -> Bool) -> FAST_STRING -> Literal -> Literal -> Maybe (RuleName, CoreExpr) +cmpOp cmp name l1 l2 + = go l1 l2 + where + done res | cmp res = Just (name, trueVal) + | otherwise = Just (name, falseVal) + + -- These compares are at different types + go (MachChar i1) (MachChar i2) = done (i1 `compare` i2) + go (MachInt i1) (MachInt i2) = done (i1 `compare` i2) + go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2) + go (MachWord i1) (MachWord i2) = done (i1 `compare` i2) + go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2) + go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2) + go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2) + go l1 l2 = Nothing -------------------------- + negOp name (MachFloat f) = Just (name, mkFloatVal (-f)) negOp name (MachDouble d) = Just (name, mkDoubleVal (-d)) -negOp name (MachInt i _) = Just (name, mkIntVal (-i)) - -chrOp name (MachChar c) = Just (name, mkIntVal (fromInt (ord c))) - -addr2IntOp name (MachAddr i) = Just (name, mkIntVal i) +negOp name l@(MachInt i) = intResult name (ppr l) (-i) +negOp name l = Nothing -------------------------- -intOp2 op name l1@(MachInt i1 s1) l2@(MachInt i2 s2) - | (result > fromInt maxInt) || (result < fromInt minInt) - -- Better tell the user that we've overflowed... - -- ..not that it stops us from actually folding! - = pprTrace "Warning:" (text "Integer overflow in expression: " <> - ppr name <+> ppr l1 <+> ppr l2) $ - Just (name, mkIntVal result) - - | otherwise - = ASSERT( s1 && s2 ) -- Both should be signed - Just (name, mkIntVal result) - where - result = i1 `op` i2 +intOp2 op name l1@(MachInt i1) l2@(MachInt i2) + = intResult name (ppr l1 <+> ppr l2) (i1 `op` i2) +intOp2 op name l1 l2 = Nothing -- Could find LitLit -intOp2Z op name (MachInt i1 s1) (MachInt i2 s2) - | i2 == 0 = Nothing -- Don't do it if the dividend < 0 - | otherwise = Just (name, mkIntVal (i1 `op` i2)) +intOp2Z op name (MachInt i1) (MachInt i2) + | i2 /= 0 = Just (name, mkIntVal (i1 `op` i2)) +intOp2Z op name l1 l2 = Nothing -- LitLit or zero dividend -------------------------- floatOp2 op name (MachFloat f1) (MachFloat f2) = Just (name, mkFloatVal (f1 `op` f2)) +floatOp2 op name l1 l2 = Nothing floatOp2Z op name (MachFloat f1) (MachFloat f2) | f1 /= 0 = Just (name, mkFloatVal (f1 `op` f2)) - | otherwise = Nothing +floatOp2Z op name l1 l2 = Nothing + -------------------------- doubleOp2 op name (MachDouble f1) (MachDouble f2) = Just (name, mkDoubleVal (f1 `op` f2)) +doubleOp2 op name l1 l2 = Nothing doubleOp2Z op name (MachDouble f1) (MachDouble f2) | f1 /= 0 = Just (name, mkDoubleVal (f1 `op` f2)) - | otherwise = Nothing +doubleOp2Z op name l1 l2 = Nothing -------------------------- @@ -207,21 +219,36 @@ doubleOp2Z op name (MachDouble f1) (MachDouble f2) -- m -> e2 -- (modulo the usual precautions to avoid duplicating e1) -litVar :: Bool -- True <=> equality, False <=> inequality +litEq :: Bool -- True <=> equality, False <=> inequality -> RuleName -> RuleFun -litVar is_eq name [Con (Literal lit) _, Var var] = do_lit_var is_eq name lit var -litVar is_eq name [Var var, Con (Literal lit) _] = do_lit_var is_eq name lit var -litVar is_eq name other = Nothing - -do_lit_var is_eq name lit var - = Just (name, Case (Var var) var [(Literal lit, [], val_if_eq), - (DEFAULT, [], val_if_neq)]) +litEq is_eq name [Lit lit, expr] = do_lit_eq is_eq name lit expr +litEq is_eq name [expr, Lit lit] = do_lit_eq is_eq name lit expr +litEq is_eq name other = Nothing + +do_lit_eq is_eq name lit expr + = Just (name, Case expr (mkWildId (literalType lit)) + [(LitAlt lit, [], val_if_eq), + (DEFAULT, [], val_if_neq)]) where val_if_eq | is_eq = trueVal | otherwise = falseVal val_if_neq | is_eq = falseVal | otherwise = trueVal + +intResult name pp_args result + | not (inIntRange result) + -- Better tell the user that we've overflowed... + -- ..not that it stops us from actually folding! + + = pprTrace "Warning:" (text "Integer overflow in:" <+> ppr name <+> pp_args) + Just (name, mkIntVal (squash result)) + + | otherwise + = Just (name, mkIntVal result) + +squash :: Integer -> Integer -- Squash into Int range +squash i = toInteger ((fromInteger i)::Int) \end{code} @@ -240,21 +267,20 @@ or_rule r1 r2 args = case r1 args of Nothing -> r2 args twoLits :: (Literal -> Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun -twoLits rule [Con (Literal l1) _, Con (Literal l2) _] = rule l1 l2 -twoLits rule other = Nothing +twoLits rule [Lit l1, Lit l2] = rule l1 l2 +twoLits rule other = Nothing oneLit :: (Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun -oneLit rule [Con (Literal l1) _] = rule l1 -oneLit rule other = Nothing +oneLit rule [Lit l1] = rule l1 +oneLit rule other = Nothing -trueVal = Con (DataCon trueDataCon) [] -falseVal = Con (DataCon falseDataCon) [] -mkIntVal i = Con (Literal (mkMachInt i)) [] -mkCharVal c = Con (Literal (MachChar c)) [] -mkWordVal w = Con (Literal (mkMachWord w)) [] -mkFloatVal f = Con (Literal (MachFloat f)) [] -mkDoubleVal d = Con (Literal (MachDouble d)) [] +trueVal = Var trueDataConId +falseVal = Var falseDataConId +mkIntVal i = Lit (mkMachInt i) +mkCharVal c = Lit (MachChar c) +mkFloatVal f = Lit (MachFloat f) +mkDoubleVal d = Lit (MachDouble d) \end{code} @@ -325,9 +351,9 @@ seqRule other = Nothing \begin{code} -tagToEnumRule [Type ty, Con (Literal (MachInt i _)) _] +tagToEnumRule [Type ty, Lit (MachInt i)] = ASSERT( isEnumerationTyCon tycon ) - Just (SLIT("TagToEnum"), Con (DataCon dc) []) + Just (SLIT("TagToEnum"), Var (dataConId dc)) where tag = fromInteger i constrs = tyConDataCons tycon @@ -344,18 +370,31 @@ For dataToTag#, we can reduce if either \begin{code} dataToTagRule [_, val_arg] - = case val_arg of - Con (DataCon dc) _ -> yes dc - Var x -> case maybeUnfoldingTemplate (getIdUnfolding x) of - Just (Con (DataCon dc) _) -> yes dc - other -> Nothing + = case maybeConApp val_arg of + Just dc -> ASSERT( not (isNewTyCon (dataConTyCon dc)) ) + Just (SLIT("DataToTag"), + mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) + other -> Nothing - where - yes dc = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) - Just (SLIT("DataToTag"), - mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) dataToTagRule other = Nothing + +maybeConApp :: CoreExpr -> Maybe DataCon +maybeConApp (Var v) + = case maybeUnfoldingTemplate (idUnfolding v) of + Just unf -> maybeConApp unf + Nothing -> Nothing + +maybeConApp expr + = go expr 0 + where + go (App f a) n | isTypeArg a = go f n + | otherwise = go f (n+1) + go (Var f) n = case isDataConId_maybe f of + Just dc -> ASSERT( n == dataConRepArity dc ) + Just dc -- Check it's saturated + other -> Nothing + go other n = Nothing \end{code} %************************************************************************ @@ -366,6 +405,7 @@ dataToTagRule other = Nothing \begin{code} builtinRules :: [ProtoCoreRule] +-- Rules for non-primops that can't be expressed using a RULE pragma builtinRules = [ ProtoCoreRule False unpackCStringFoldrId (BuiltinRule match_append_lit_str) @@ -375,10 +415,10 @@ builtinRules -- unpack "foo" c (unpack "baz" c n) = unpack "foobaz" c n match_append_lit_str [Type ty1, - Con (Literal (MachStr s1)) [], + Lit (MachStr s1), c1, Var unpk `App` Type ty2 - `App` Con (Literal (MachStr s2)) [] + `App` Lit (MachStr s2) `App` c2 `App` n ] @@ -387,7 +427,7 @@ match_append_lit_str [Type ty1, = ASSERT( ty1 == ty2 ) Just (SLIT("AppendLitString"), Var unpk `App` Type ty1 - `App` Con (Literal (MachStr (s1 _APPEND_ s2))) [] + `App` Lit (MachStr (s1 _APPEND_ s2)) `App` c1 `App` n) diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 1db87575c7..a6dce94f43 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -11,13 +11,15 @@ module PrimOp ( commutableOp, - primOpOutOfLine, primOpNeedsWrapper, primOpStrictness, + primOpOutOfLine, primOpNeedsWrapper, primOpOkForSpeculation, primOpIsCheap, primOpIsDupable, primOpHasSideEffects, getPrimOpResultInfo, PrimOpResultInfo(..), - pprPrimOp + pprPrimOp, + + CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp ) where #include "HsVersions.h" @@ -26,7 +28,7 @@ import PrimRep -- most of it import TysPrim import TysWiredIn -import Demand ( Demand, wwLazy, wwPrim, wwStrict ) +import Demand ( Demand, wwLazy, wwPrim, wwStrict, StrictnessInfo(..) ) import Var ( TyVar, Id ) import CallConv ( CallConv, pprCallConv ) import PprType ( pprParendType ) @@ -199,83 +201,9 @@ data PrimOp | MakeStablePtrOp | DeRefStablePtrOp | EqStablePtrOp -\end{code} - -A special ``trap-door'' to use in making calls direct to C functions: -\begin{code} - | CCallOp (Either - FAST_STRING -- Left fn => An "unboxed" ccall# to `fn'. - Unique) -- Right u => first argument (an Addr#) is the function pointer - -- (unique is used to generate a 'typedef' to cast - -- the function pointer if compiling the ccall# down to - -- .hc code - can't do this inline for tedious reasons.) - - Bool -- True <=> really a "casm" - Bool -- True <=> might invoke Haskell GC - CallConv -- calling convention to use. - - -- (... to be continued ... ) -\end{code} - -The ``type'' of @CCallOp foo [t1, ... tm] r@ is @t1 -> ... tm -> r@. -(See @primOpInfo@ for details.) - -Note: that first arg and part of the result should be the system state -token (which we carry around to fool over-zealous optimisers) but -which isn't actually passed. - -For example, we represent -\begin{pseudocode} -((ccall# foo [StablePtr# a, Int] Float) sp# i#) :: (Float, IoWorld) -\end{pseudocode} -by -\begin{pseudocode} -Case - ( Prim - (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False) - -- :: Universe# -> StablePtr# a -> Int# -> FloatPrimAndUniverse - [] - [w#, sp# i#] - ) - (AlgAlts [ ( FloatPrimAndIoWorld, - [f#, w#], - Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#] - ) ] - NoDefault - ) -\end{pseudocode} - -Nota Bene: there are some people who find the empty list of types in -the @Prim@ somewhat puzzling and would represent the above by -\begin{pseudocode} -Case - ( Prim - (CCallOp "foo" [alpha1, alpha2, alpha3] alpha4 False) - -- :: /\ alpha1, alpha2 alpha3, alpha4. - -- alpha1 -> alpha2 -> alpha3 -> alpha4 - [Universe#, StablePtr# a, Int#, FloatPrimAndIoWorld] - [w#, sp# i#] - ) - (AlgAlts [ ( FloatPrimAndIoWorld, - [f#, w#], - Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#] - ) ] - NoDefault - ) -\end{pseudocode} - -But, this is a completely different way of using @CCallOp@. The most -major changes required if we switch to this are in @primOpInfo@, and -the desugarer. The major difficulty is in moving the HeapRequirement -stuff somewhere appropriate. (The advantage is that we could simplify -@CCallOp@ and record just the number of arguments with corresponding -simplifications in reading pragma unfoldings, the simplifier, -instantiation (etc) of core expressions, ... . Maybe we should think -about using it this way?? ADR) - -\begin{code} - -- (... continued from above ... ) + -- Foreign calls + | CCallOp CCall -- Operation to test two closure addresses for equality (yes really!) -- BLAME ALASTAIR REID FOR THIS! THE REST OF US ARE INNOCENT! | ReallyUnsafePtrEqualityOp @@ -542,7 +470,6 @@ tagOf_PrimOp StableNameToIntOp = ILIT(229) tagOf_PrimOp MakeStablePtrOp = ILIT(230) tagOf_PrimOp DeRefStablePtrOp = ILIT(231) tagOf_PrimOp EqStablePtrOp = ILIT(232) -tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(233) tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(234) tagOf_PrimOp SeqOp = ILIT(235) tagOf_PrimOp ParOp = ILIT(236) @@ -573,7 +500,6 @@ tagOf_PrimOp DataToTagOp = ILIT(260) tagOf_PrimOp TagToEnumOp = ILIT(261) tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op) ---panic# "tagOf_PrimOp: pattern-match" instance Eq PrimOp where op1 == op2 = tagOf_PrimOp op1 _EQ_ tagOf_PrimOp op2 @@ -596,7 +522,7 @@ instance Show PrimOp where An @Enum@-derived list would be better; meanwhile... (ToDo) \begin{code} -allThePrimOps +allThePrimOps -- Except CCall, which is really a family of primops = [ CharGtOp, CharGeOp, CharEqOp, @@ -930,42 +856,45 @@ integerCompare name = mkGenPrimOp name [] two_Integer_tys intPrimTy Not all primops are strict! \begin{code} -primOpStrictness :: PrimOp -> ([Demand], Bool) - -- See IdInfo.StrictnessInfo for discussion of what the results - -- **NB** as a cheap hack, to avoid having to look up the PrimOp's arity, - -- the list of demands may be infinite! - -- Use only the ones you ned. +primOpStrictness :: Arity -> PrimOp -> StrictnessInfo + -- See Demand.StrictnessInfo for discussion of what the results + -- The arity should be the arity of the primop; that's why + -- this function isn't exported. -primOpStrictness SeqOp = ([wwStrict], False) +primOpStrictness arity SeqOp = StrictnessInfo [wwStrict] False -- Seq is strict in its argument; see notes in ConFold.lhs -primOpStrictness ParOp = ([wwLazy], False) - -- But Par is lazy, to avoid that the sparked thing +primOpStrictness arity ParOp = StrictnessInfo [wwLazy] False + -- Note that Par is lazy to avoid that the sparked thing -- gets evaluted strictly, which it should *not* be -primOpStrictness ForkOp = ([wwLazy, wwPrim], False) +primOpStrictness arity ForkOp = StrictnessInfo [wwLazy, wwPrim] False + +primOpStrictness arity NewArrayOp = StrictnessInfo [wwPrim, wwLazy, wwPrim] False +primOpStrictness arity WriteArrayOp = StrictnessInfo [wwPrim, wwPrim, wwLazy, wwPrim] False -primOpStrictness NewArrayOp = ([wwPrim, wwLazy, wwPrim], False) -primOpStrictness WriteArrayOp = ([wwPrim, wwPrim, wwLazy, wwPrim], False) +primOpStrictness arity NewMutVarOp = StrictnessInfo [wwLazy, wwPrim] False +primOpStrictness arity WriteMutVarOp = StrictnessInfo [wwPrim, wwLazy, wwPrim] False -primOpStrictness NewMutVarOp = ([wwLazy, wwPrim], False) -primOpStrictness WriteMutVarOp = ([wwPrim, wwLazy, wwPrim], False) +primOpStrictness arity PutMVarOp = StrictnessInfo [wwPrim, wwLazy, wwPrim] False -primOpStrictness PutMVarOp = ([wwPrim, wwLazy, wwPrim], False) +primOpStrictness arity CatchOp = StrictnessInfo [wwLazy, wwLazy, wwPrim] False + -- Catch is actually strict in its first argument + -- but we don't want to tell the strictness + -- analyser about that! -primOpStrictness CatchOp = ([wwLazy, wwLazy, wwPrim], False) -primOpStrictness RaiseOp = ([wwLazy], True) -- NB: True => result is bottom -primOpStrictness BlockAsyncExceptionsOp = ([wwLazy], False) -primOpStrictness UnblockAsyncExceptionsOp = ([wwLazy], False) +primOpStrictness arity RaiseOp = StrictnessInfo [wwLazy] True -- NB: True => result is bottom +primOpStrictness arity BlockAsyncExceptionsOp = StrictnessInfo [wwLazy] False +primOpStrictness arity UnblockAsyncExceptionsOp = StrictnessInfo [wwLazy] False -primOpStrictness MkWeakOp = ([wwLazy, wwLazy, wwLazy, wwPrim], False) -primOpStrictness MakeStableNameOp = ([wwLazy, wwPrim], False) -primOpStrictness MakeStablePtrOp = ([wwLazy, wwPrim], False) +primOpStrictness arity MkWeakOp = StrictnessInfo [wwLazy, wwLazy, wwLazy, wwPrim] False +primOpStrictness arity MakeStableNameOp = StrictnessInfo [wwLazy, wwPrim] False +primOpStrictness arity MakeStablePtrOp = StrictnessInfo [wwLazy, wwPrim] False -primOpStrictness DataToTagOp = ([wwLazy], False) +primOpStrictness arity DataToTagOp = StrictnessInfo [wwLazy] False -- The rest all have primitive-typed arguments -primOpStrictness other = (repeat wwPrim, False) +primOpStrictness arity other = StrictnessInfo (replicate arity wwPrim) False \end{code} %************************************************************************ @@ -1935,24 +1864,6 @@ primOpInfo NoFollowOp -- noFollow# :: a -> Int# %************************************************************************ %* * -\subsubsection[PrimOp-IO-etc]{PrimOpInfo for C calls, and I/O-ish things} -%* * -%************************************************************************ - -\begin{code} -primOpInfo (CCallOp _ _ _ _) - = mkGenPrimOp SLIT("ccall#") [alphaTyVar] [] alphaTy - -{- -primOpInfo (CCallOp _ _ _ _ arg_tys result_ty) - = mkGenPrimOp SLIT("ccall#") [] arg_tys result_tycon tys_applied - where - (result_tycon, tys_applied, _) = splitAlgTyConApp result_ty --} -\end{code} - -%************************************************************************ -%* * \subsubsection[PrimOp-tag]{PrimOpInfo for @dataToTag#@ and @tagToEnum#@} %* * %************************************************************************ @@ -1973,7 +1884,7 @@ primOpInfo TagToEnumOp = mkGenPrimOp SLIT("tagToEnum#") [alphaTyVar] [intPrimTy] alphaTy #ifdef DEBUG -primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op))) +primOpInfo op = pprPanic "primOpInfo:" (ppr op) #endif \end{code} @@ -1989,49 +1900,52 @@ perform a heap check or they block. \begin{code} primOpOutOfLine op = case op of - TakeMVarOp -> True - PutMVarOp -> True - DelayOp -> True - WaitReadOp -> True - WaitWriteOp -> True - CatchOp -> True - RaiseOp -> True - BlockAsyncExceptionsOp -> True - UnblockAsyncExceptionsOp -> True - NewArrayOp -> True - NewByteArrayOp _ -> True - IntegerAddOp -> True - IntegerSubOp -> True - IntegerMulOp -> True - IntegerGcdOp -> True - IntegerDivExactOp -> True - IntegerQuotOp -> True - IntegerRemOp -> True - IntegerQuotRemOp -> True - IntegerDivModOp -> True - Int2IntegerOp -> True - Word2IntegerOp -> True - Addr2IntegerOp -> True - Word64ToIntegerOp -> True - Int64ToIntegerOp -> True - FloatDecodeOp -> True - DoubleDecodeOp -> True - MkWeakOp -> True - FinalizeWeakOp -> True - MakeStableNameOp -> True - MakeForeignObjOp -> True - NewMutVarOp -> True - NewMVarOp -> True - ForkOp -> True - KillThreadOp -> True - YieldOp -> True - CCallOp _ _ may_gc@True _ -> True -- _ccall_GC_ - -- the next one doesn't perform any heap checks, + TakeMVarOp -> True + PutMVarOp -> True + DelayOp -> True + WaitReadOp -> True + WaitWriteOp -> True + CatchOp -> True + RaiseOp -> True + BlockAsyncExceptionsOp -> True + UnblockAsyncExceptionsOp -> True + NewArrayOp -> True + NewByteArrayOp _ -> True + IntegerAddOp -> True + IntegerSubOp -> True + IntegerMulOp -> True + IntegerGcdOp -> True + IntegerDivExactOp -> True + IntegerQuotOp -> True + IntegerRemOp -> True + IntegerQuotRemOp -> True + IntegerDivModOp -> True + Int2IntegerOp -> True + Word2IntegerOp -> True + Addr2IntegerOp -> True + Word64ToIntegerOp -> True + Int64ToIntegerOp -> True + FloatDecodeOp -> True + DoubleDecodeOp -> True + MkWeakOp -> True + FinalizeWeakOp -> True + MakeStableNameOp -> True + MakeForeignObjOp -> True + NewMutVarOp -> True + NewMVarOp -> True + ForkOp -> True + KillThreadOp -> True + YieldOp -> True + + UnsafeThawArrayOp -> True + -- UnsafeThawArrayOp doesn't perform any heap checks, -- but it is of such an esoteric nature that -- it is done out-of-line rather than require -- the NCG to implement it. - UnsafeThawArrayOp -> True - _ -> False + + CCallOp ccall -> ccallMayGC ccall + + other -> False \end{code} @@ -2084,10 +1998,8 @@ duplicate into different case branches. See CoreUtils.exprIsDupable. \begin{code} primOpIsDupable :: PrimOp -> Bool -- See comments with CoreUtils.exprIsDupable -primOpIsDupable (CCallOp _ _ might_gc _) = not might_gc - -- If the ccall can't GC then the call is pretty cheap, and - -- we're happy to duplicate -primOpIsDupable op = not (primOpOutOfLine op) + -- We say it's dupable it isn't implemented by a C call with a wrapper +primOpIsDupable op = not (primOpNeedsWrapper op) \end{code} @@ -2166,9 +2078,7 @@ primOpHasSideEffects ParAtRelOp = True primOpHasSideEffects ParAtForNowOp = True primOpHasSideEffects CopyableOp = True -- Possibly not. ASP primOpHasSideEffects NoFollowOp = True -- Possibly not. ASP - --- CCall -primOpHasSideEffects (CCallOp _ _ _ _) = True +primOpHasSideEffects (CCallOp _) = True primOpHasSideEffects other = False \end{code} @@ -2179,7 +2089,7 @@ any live variables that are stored in caller-saves registers. \begin{code} primOpNeedsWrapper :: PrimOp -> Bool -primOpNeedsWrapper (CCallOp _ _ _ _) = True +primOpNeedsWrapper (CCallOp _) = True primOpNeedsWrapper Integer2IntOp = True primOpNeedsWrapper Integer2WordOp = True @@ -2266,15 +2176,20 @@ primOpOcc op = case (primOpInfo op) of -- primOpSig is like primOpType but gives the result split apart: -- (type variables, argument types, result type) +-- It also gives arity, strictness info -primOpSig :: PrimOp -> ([TyVar],[Type],Type) +primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictnessInfo) primOpSig op - = case (primOpInfo op) of - Monadic occ ty -> ([], [ty], ty ) - Dyadic occ ty -> ([], [ty,ty], ty ) - Compare occ ty -> ([], [ty,ty], boolTy) - GenPrimOp occ tyvars arg_tys res_ty - -> (tyvars, arg_tys, res_ty) + = (tyvars, arg_tys, res_ty, arity, primOpStrictness arity op) + where + arity = length arg_tys + (tyvars, arg_tys, res_ty) + = case (primOpInfo op) of + Monadic occ ty -> ([], [ty], ty ) + Dyadic occ ty -> ([], [ty,ty], ty ) + Compare occ ty -> ([], [ty,ty], boolTy) + GenPrimOp occ tyvars arg_tys res_ty + -> (tyvars, arg_tys, res_ty) -- primOpUsg is like primOpSig but the types it yields are the -- appropriate sigma (i.e., usage-annotated) types, @@ -2343,7 +2258,7 @@ primOpUsg op CopyableOp -> mangle [mkZ ] mkR NoFollowOp -> mangle [mkZ ] mkR - CCallOp _ _ _ _ -> mangle [ ] mkM + CCallOp _ -> mangle [ ] mkM -- Things with no Haskell pointers inside: in actuality, usages are -- irrelevant here (hence it doesn't matter that some of these @@ -2360,8 +2275,7 @@ primOpUsg op mkP = mkUsgTy UsOnce -- unpointed argument mkR = mkUsgTy UsMany -- unpointed result - (tyvars, arg_tys, res_ty) - = primOpSig op + (tyvars, arg_tys, res_ty, _, _) = primOpSig op nomangle = (tyvars, map mkP arg_tys, mkR res_ty) @@ -2388,6 +2302,8 @@ data PrimOpResultInfo -- be out of line, or the code generator won't work. getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo +getPrimOpResultInfo (CCallOp _) + = ReturnsAlg unboxedPairTyCon getPrimOpResultInfo op = case (primOpInfo op) of Dyadic _ ty -> ReturnsPrim (typePrimRep ty) @@ -2400,12 +2316,6 @@ getPrimOpResultInfo op Nothing -> panic "getPrimOpResultInfo" Just (tc,_,_) -> ReturnsAlg tc other -> ReturnsPrim other - -isCompareOp :: PrimOp -> Bool -isCompareOp op - = case primOpInfo op of - Compare _ _ -> True - _ -> False \end{code} The commutable ops are those for which we will try to move constants @@ -2458,8 +2368,55 @@ Output stuff: \begin{code} pprPrimOp :: PrimOp -> SDoc -pprPrimOp (CCallOp fun is_casm may_gc cconv) - = let +pprPrimOp (CCallOp ccall) = pprCCallOp ccall +pprPrimOp other_op + = getPprStyle $ \ sty -> + if ifaceStyle sty then -- For interfaces Print it qualified with PrelGHC. + ptext SLIT("PrelGHC.") <> pprOccName occ + else + pprOccName occ + where + occ = primOpOcc other_op +\end{code} + + +\end{code} + + +%************************************************************************ +%* * +\subsubsection{CCalls} +%* * +%************************************************************************ + +A special ``trap-door'' to use in making calls direct to C functions: +\begin{code} +data CCall + = CCall CCallTarget + Bool -- True <=> really a "casm" + Bool -- True <=> might invoke Haskell GC + CallConv -- calling convention to use. + +data CCallTarget + = StaticTarget FAST_STRING -- An "unboxed" ccall# to `fn'. + | DynamicTarget Unique -- First argument (an Addr#) is the function pointer + -- (unique is used to generate a 'typedef' to cast + -- the function pointer if compiling the ccall# down to + -- .hc code - can't do this inline for tedious reasons.) + +ccallMayGC :: CCall -> Bool +ccallMayGC (CCall _ _ may_gc _) = may_gc + +ccallIsCasm :: CCall -> Bool +ccallIsCasm (CCall _ c_asm _ _) = c_asm +\end{code} + +\begin{code} +pprCCallOp (CCall fun is_casm may_gc cconv) + = hcat [ ifPprDebug callconv + , text "__", ppr_dyn + , text before , ppr_fun , after] + where callconv = text "{-" <> pprCallConv cconv <> text "-}" before @@ -2472,27 +2429,11 @@ pprPrimOp (CCallOp fun is_casm may_gc cconv) | is_casm = text "''" | otherwise = empty - ppr_dyn = - case fun of - Right _ -> text "dyn_" - _ -> empty - - ppr_fun = - case fun of - Right _ -> text "\"\"" - Left fn -> ptext fn - - in - hcat [ ifPprDebug callconv - , text "__", ppr_dyn - , text before , ppr_fun , after] + ppr_dyn = case fun of + DynamicTarget _ -> text "dyn_" + _ -> empty -pprPrimOp other_op - = getPprStyle $ \ sty -> - if ifaceStyle sty then -- For interfaces Print it qualified with PrelGHC. - ptext SLIT("PrelGHC.") <> pprOccName occ - else - pprOccName occ - where - occ = primOpOcc other_op + ppr_fun = case fun of + DynamicTarget _ -> text "\"\"" + StaticTarget fn -> ptext fn \end{code} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index f4542a6ec6..a8bcf25ee4 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -24,7 +24,7 @@ module TysWiredIn ( doubleTy, isDoubleTy, doubleTyCon, - falseDataCon, + falseDataCon, falseDataConId, floatDataCon, floatTy, isFloatTy, @@ -34,7 +34,6 @@ module TysWiredIn ( intTy, intTyCon, isIntTy, - inIntRange, integerTy, integerTyCon, @@ -49,7 +48,7 @@ module TysWiredIn ( -- tuples mkTupleTy, - tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon, + tupleTyCon, tupleCon, unitTyCon, unitDataConId, pairTyCon, -- unboxed tuples mkUnboxedTupleTy, @@ -58,7 +57,7 @@ module TysWiredIn ( stablePtrTyCon, stringTy, - trueDataCon, + trueDataCon, trueDataConId, unitTy, voidTy, wordDataCon, @@ -75,7 +74,7 @@ module TysWiredIn ( #include "HsVersions.h" -import {-# SOURCE #-} MkId( mkDataConId ) +import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId ) -- friends: import PrelMods @@ -84,8 +83,8 @@ import TysPrim -- others: import Constants ( mAX_TUPLE_SIZE ) import Module ( Module, mkPrelModule ) -import Name ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, dataName ) -import DataCon ( DataCon, StrictnessMark(..), mkDataCon ) +import Name ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, mkWorkerOcc, dataName ) +import DataCon ( DataCon, StrictnessMark(..), mkDataCon, dataConId ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon ) import BasicTypes ( Arity, NewOrData(..), RecFlag(..) ) @@ -137,15 +136,25 @@ pcSynTyCon key mod str kind arity tyvars expansion argvrcs -- this fun never us pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon -pcDataCon key mod str tyvars context arg_tys tycon +-- The unique is the first of two free uniques; +-- the first is used for the datacon itself and the worker; +-- the second is used for the wrapper. +pcDataCon wrap_key mod str tyvars context arg_tys tycon = data_con where - data_con = mkDataCon name + data_con = mkDataCon wrap_name [ NotMarkedStrict | a <- arg_tys ] [ {- no labelled fields -} ] - tyvars context [] [] arg_tys tycon id - name = mkWiredInIdName key mod (mkSrcOccFS dataName str) id - id = mkDataConId data_con + tyvars context [] [] arg_tys tycon work_id wrap_id + + work_occ = mkWorkerOcc wrap_occ + work_key = incrUnique wrap_key + work_name = mkWiredInIdName work_key mod work_occ work_id + work_id = mkDataConId work_name data_con + + wrap_occ = mkSrcOccFS dataName str + wrap_name = mkWiredInIdName wrap_key mod wrap_occ wrap_id + wrap_id = mkDataConWrapId data_con \end{code} %************************************************************************ @@ -193,8 +202,7 @@ mk_tuple arity = (tycon, tuple_con) unitTyCon = tupleTyCon 0 pairTyCon = tupleTyCon 2 -unitDataCon = tupleCon 0 -pairDataCon = tupleCon 2 +unitDataConId = dataConId (tupleCon 0) \end{code} %************************************************************************ @@ -282,14 +290,6 @@ isIntTy ty = case (splitAlgTyConApp_maybe ty) of Just (tycon, [], _) -> getUnique tycon == intTyConKey _ -> False - -inIntRange :: Integer -> Bool -- Tells if an integer lies in the legal range of Ints -inIntRange i = (min_int <= i) && (i <= max_int) - -max_int, min_int :: Integer -max_int = toInteger maxInt -min_int = toInteger minInt - \end{code} \begin{code} @@ -526,6 +526,9 @@ boolTyCon = pcTyCon EnumType NonRecursive boolTyConKey falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon trueDataCon = pcDataCon trueDataConKey pREL_BASE SLIT("True") [] [] [] boolTyCon + +falseDataConId = dataConId falseDataCon +trueDataConId = dataConId trueDataCon \end{code} %************************************************************************ diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index a87754ec8c..5af05432a8 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -31,7 +31,6 @@ import StgSyn import CmdLineOpts ( opt_AutoSccsOnIndividualCafs ) import CostCentre -- lots of things -import Const ( Con(..) ) import Id ( Id, mkSysLocal, idType, idName ) import Module ( Module ) import UniqSupply ( uniqFromSupply, splitUniqSupply, UniqSupply ) @@ -40,7 +39,7 @@ import Type ( splitForAllTys, splitTyConApp_maybe ) import TyCon ( isFunTyCon ) import VarSet import UniqSet -import Name ( isLocallyDefinedName ) +import Name ( isLocallyDefined ) import Util ( removeDups ) import Outputable @@ -108,7 +107,7 @@ stgMassageForProfiling mod_name us stg_binds ---------- do_top_rhs :: Id -> StgRhs -> MassageM StgRhs - do_top_rhs binder (StgRhsClosure _ bi srt fv u [] (StgSCC cc (StgCon (DataCon con) args _))) + do_top_rhs binder (StgRhsClosure _ bi srt fv u [] (StgSCC cc (StgConApp con args))) | not (isSccCountCostCentre cc) -- Trivial _scc_ around nothing but static data -- Eliminate _scc_ ... and turn into StgRhsCon @@ -174,11 +173,16 @@ stgMassageForProfiling mod_name us stg_binds ------ do_expr :: StgExpr -> MassageM StgExpr + do_expr (StgLit l) = returnMM (StgLit l) + do_expr (StgApp fn args) = boxHigherOrderArgs (StgApp fn) args - do_expr (StgCon con args res_ty) - = boxHigherOrderArgs (\args -> StgCon con args res_ty) args + do_expr (StgConApp con args) + = boxHigherOrderArgs (\args -> StgConApp con args) args + + do_expr (StgPrimApp con args res_ty) + = boxHigherOrderArgs (\args -> StgPrimApp con args res_ty) args do_expr (StgSCC cc expr) -- Ha, we found a cost centre! = collectCC cc `thenMM_` @@ -301,23 +305,20 @@ boxHigherOrderArgs almost_expr args returnMM (foldr (mk_stg_let currentCCS) (almost_expr new_args) let_bindings) where --------------- - do_arg ids bindings atom@(StgConArg _) = returnMM (bindings, atom) - do_arg ids bindings atom@(StgVarArg old_var) - = let - var_type = idType old_var + do_arg ids bindings arg@(StgVarArg old_var) + | (not (isLocallyDefined old_var) || elemVarSet old_var ids) + && isFunType var_type + = -- make a trivial let-binding for the top-level function + getUniqueMM `thenMM` \ uniq -> + let + new_var = mkSysLocal SLIT("sf") uniq var_type in - if ( not (isLocallyDefinedName (idName old_var)) || - elemVarSet old_var ids ) && isFunType var_type - then - -- make a trivial let-binding for the top-level function - getUniqueMM `thenMM` \ uniq -> - let - new_var = mkSysLocal SLIT("sf") uniq var_type - in - returnMM ( (new_var, old_var) : bindings, StgVarArg new_var ) - else - returnMM (bindings, atom) + returnMM ( (new_var, old_var) : bindings, StgVarArg new_var ) + where + var_type = idType old_var + + do_arg ids bindings arg = returnMM (bindings, arg) --------------- mk_stg_let :: CostCentreStack -> (Id, Id) -> StgExpr -> StgExpr diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index a151fe4caf..40cc45165a 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -7,14 +7,16 @@ import HsSyn -- quite a bit of stuff import RdrHsSyn -- oodles of synonyms import HsTypes ( mkHsForAllTy, mkHsUsForAllTy ) import HsCore -import Const ( Literal(..), mkMachInt_safe ) +import Literal ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 ) import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), Version ) import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) ) +import CallConv ( cCallConv ) import HsPragmas ( noDataPragmas, noClassPragmas ) import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind, UsageAnn(..) ) import IdInfo ( ArityInfo, exactArity, CprInfo(..), InlinePragInfo(..) ) +import PrimOp ( CCall(..), CCallTarget(..) ) import Lex import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..), @@ -23,14 +25,13 @@ import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(.. ) import Bag ( emptyBag, unitBag, snocBag ) import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) -import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual ) +import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual, mkRdrNameWkr ) import Name ( OccName, Provenance ) import OccName ( mkSysOccFS, tcName, varName, ipName, dataName, clsName, tvName, uvName, EncodedFS ) import Module ( ModuleName, mkSysModuleFS ) -import PrelMods ( mkTupNameStr, mkUbxTupNameStr ) import PrelInfo ( mkTupConRdrName, mkUbxTupConRdrName ) import SrcLoc ( SrcLoc ) import Maybes @@ -95,6 +96,9 @@ import Ratio ( (%) ) '__bot' { ITbottom } '__integer' { ITinteger_lit } '__float' { ITfloat_lit } + '__word' { ITword_lit } + '__int64' { ITint64_lit } + '__word64' { ITword64_lit } '__rational' { ITrational_lit } '__addr' { ITaddr_lit } '__litlit' { ITlit_lit } @@ -112,8 +116,8 @@ import Ratio ( (%) ) '__U' { ITunfold $$ } '__S' { ITstrict $$ } '__R' { ITrules } + '__M' { ITcprinfo } '__D' { ITdeprecated } - '__M' { ITcprinfo $$ } '..' { ITdotdot } -- reserved symbols '::' { ITdcolon } @@ -405,15 +409,15 @@ constrs1 : constr { [$1] } | constr '|' constrs1 { $1 : $3 } constr :: { RdrNameConDecl } -constr : src_loc ex_stuff data_name batypes { mkConDecl $3 $2 (VanillaCon $4) $1 } - | src_loc ex_stuff data_name '{' fields1 '}' { mkConDecl $3 $2 (RecCon $5) $1 } +constr : src_loc ex_stuff data_name batypes { mk_con_decl $3 $2 (VanillaCon $4) $1 } + | src_loc ex_stuff data_name '{' fields1 '}' { mk_con_decl $3 $2 (RecCon $5) $1 } -- We use "data_fs" so as to include () newtype_constr :: { [RdrNameConDecl] {- Empty if handwritten abstract -} } newtype_constr : { [] } - | src_loc '=' ex_stuff data_name atype { [mkConDecl $4 $3 (NewCon $5 Nothing) $1] } + | src_loc '=' ex_stuff data_name atype { [mk_con_decl $4 $3 (NewCon $5 Nothing) $1] } | src_loc '=' ex_stuff data_name '{' var_name '::' atype '}' - { [mkConDecl $4 $3 (NewCon $8 (Just $6)) $1] } + { [mk_con_decl $4 $3 (NewCon $8 (Just $6)) $1] } ex_stuff :: { ([HsTyVar RdrName], RdrNameContext) } ex_stuff : { ([],[]) } @@ -662,7 +666,7 @@ id_info :: { [HsIdInfo RdrName] } id_info_item :: { HsIdInfo RdrName } : '__A' INTEGER { HsArity (exactArity (fromInteger $2)) } | '__U' inline_prag core_expr { HsUnfold $2 $3 } - | '__M' { HsCprInfo $1 } + | '__M' { HsCprInfo } | '__S' { HsStrictness (HsStrictnessInfo $1) } | '__C' { HsNoCafRefs } | '__P' qvar_name { HsWorker $2 } @@ -683,8 +687,7 @@ core_expr : '\\' core_bndrs '->' core_expr { foldr UfLam $4 $2 } | '__letrec' '{' rec_binds '}' 'in' core_expr { UfLet (UfRec $3) $6 } - | con_or_primop '{' core_args '}' { UfCon $1 $3 } - | '__litlit' STRING atype { UfCon (UfLitLitCon $2 $3) [] } + | '__litlit' STRING atype { UfLitLit $2 $3 } | '__inline_me' core_expr { UfNote UfInlineMe $2 } | '__inline_call' core_expr { UfNote UfInlineCall $2 } @@ -706,7 +709,6 @@ core_args :: { [UfExpr RdrName] } core_aexpr :: { UfExpr RdrName } -- Atomic expressions core_aexpr : qvar_name { UfVar $1 } - | qdata_name { UfVar $1 } -- This one means that e.g. "True" will parse as -- (UfVar True_Id) rather than (UfCon True_Con []). @@ -717,14 +719,30 @@ core_aexpr : qvar_name { UfVar $1 } -- If you want to get a UfCon, then use the -- curly-bracket notation (True {}). - | core_lit { UfCon (UfLitCon $1) [] } - | '(' core_expr ')' { $2 } - | '(' comma_exprs2 ')' { UfTuple (mkTupConRdrName (length $2)) $2 } - | '(#' comma_exprs0 '#)' { UfTuple (mkUbxTupConRdrName (length $2)) $2 } - -- This one is dealt with by qdata_name: see above comments -- | '(' ')' { UfTuple (mkTupConRdrName 0) [] } + | core_lit { UfLit $1 } + | '(' core_expr ')' { $2 } + + -- Tuple construtors are for the *worker* of the tuple + -- Going direct saves needless messing about + | '(' comma_exprs2 ')' { UfTuple (mkRdrNameWkr (mkTupConRdrName (length $2))) $2 } + | '(#' comma_exprs0 '#)' { UfTuple (mkRdrNameWkr (mkUbxTupConRdrName (length $2))) $2 } + + | '{' '__ccall' ccall_string type '}' + { let + (is_dyn, is_casm, may_gc) = $2 + + target | is_dyn = DynamicTarget (error "CCall dyn target bogus unique") + | otherwise = StaticTarget $3 + + ccall = CCall target is_casm may_gc cCallConv + in + UfCCall ccall $4 + } + + comma_exprs0 :: { [UfExpr RdrName] } -- Zero or more comma_exprs0 : {- empty -} { [ ] } | core_expr { [ $1 ] } @@ -734,15 +752,6 @@ comma_exprs2 :: { [UfExpr RdrName] } -- Two or more comma_exprs2 : core_expr ',' core_expr { [$1,$3] } | core_expr ',' comma_exprs2 { $1 : $3 } -con_or_primop :: { UfCon RdrName } -con_or_primop : qdata_name { UfDataCon $1 } - | qvar_name { UfPrimOp $1 } - | '__ccall' ccall_string { let - (is_dyn, is_casm, may_gc) = $1 - in - UfCCallOp $2 is_dyn is_casm may_gc - } - rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } : { [] } | core_val_bndr '=' core_expr ';' rec_binds { ($1,$3) : $5 } @@ -754,12 +763,12 @@ core_alts :: { [UfAlt RdrName] } core_alt :: { UfAlt RdrName } core_alt : core_pat '->' core_expr { (fst $1, snd $1, $3) } -core_pat :: { (UfCon RdrName, [RdrName]) } -core_pat : core_lit { (UfLitCon $1, []) } - | '__litlit' STRING atype { (UfLitLitCon $2 $3, []) } - | qdata_name core_pat_names { (UfDataCon $1, $2) } - | '(' comma_var_names1 ')' { (UfDataCon (mkTupConRdrName (length $2)), $2) } - | '(#' comma_var_names1 '#)' { (UfDataCon (mkUbxTupConRdrName (length $2)), $2) } +core_pat :: { (UfConAlt RdrName, [RdrName]) } +core_pat : core_lit { (UfLitAlt $1, []) } + | '__litlit' STRING atype { (UfLitLitAlt $2 $3, []) } + | qdata_name core_pat_names { (UfDataAlt $1, $2) } + | '(' comma_var_names1 ')' { (UfDataAlt (mkTupConRdrName (length $2)), $2) } + | '(#' comma_var_names1 '#)' { (UfDataAlt (mkUbxTupConRdrName (length $2)), $2) } | '__DEFAULT' { (UfDefault, []) } | '(' core_pat ')' { $2 } @@ -780,22 +789,14 @@ comma_var_names1 : var_name { [$1] } | var_name ',' comma_var_names1 { $1 : $3 } core_lit :: { Literal } -core_lit : integer { mkMachInt_safe $1 } +core_lit : integer { mkMachInt $1 } | CHAR { MachChar $1 } | STRING { MachStr $1 } - | '__string' STRING { NoRepStr $2 (panic "NoRepStr type") } | rational { MachDouble $1 } + | '__word' integer { mkMachWord $2 } + | '__word64' integer { mkMachWord64 $2 } + | '__int64' integer { mkMachInt64 $2 } | '__float' rational { MachFloat $2 } - - | '__integer' integer { NoRepInteger $2 (panic "NoRepInteger type") - -- The type checker will add the types - } - - | '__rational' integer integer { NoRepRational ($2 % $3) - (panic "NoRepRational type") - -- The type checker will add the type - } - | '__addr' integer { MachAddr $2 } integer :: { Integer } @@ -868,5 +869,5 @@ data IfaceStuff = PIface EncodedFS{-.hi module name-} ParsedIface | PRules [RdrNameRuleDecl] | PDeprecs [RdrNameDeprecation] -mkConDecl name (ex_tvs, ex_ctxt) details loc = ConDecl name ex_tvs ex_ctxt details loc +mk_con_decl name (ex_tvs, ex_ctxt) details loc = mkConDecl name ex_tvs ex_ctxt details loc } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 211b80162b..359f284133 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -29,10 +29,11 @@ import RnEnv ( availName, availsToNameSet, ) import Module ( Module, ModuleName, mkSearchPath, mkThisModule ) import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc, - nameOccName, nameUnique, isUserImportedExplicitlyName, + nameOccName, nameUnique, + isUserImportedExplicitlyName, isUserImportedName, maybeWiredInTyConName, maybeWiredInIdName, isWiredInName ) -import OccName ( occNameFlavour ) +import OccName ( occNameFlavour, isValOcc ) import Id ( idType ) import TyCon ( isSynTyCon, getSynTyConDefn ) import NameSet @@ -98,6 +99,7 @@ rename this_mod@(HsModule mod_name vers _ imports local_decls mod_deprec loc) else let Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff + ExportEnv export_avails _ _ = export_env in -- RENAME THE SOURCE @@ -108,10 +110,15 @@ rename this_mod@(HsModule mod_name vers _ imports local_decls mod_deprec loc) -- SLURP IN ALL THE NEEDED DECLARATIONS implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs -> let - real_source_fvs = implicit_fvs `plusFV` source_fvs + real_source_fvs = implicit_fvs `plusFV` source_fvs `plusFV` export_fvs -- It's important to do the "plus" this way round, so that -- when compiling the prelude, locally-defined (), Bool, etc -- override the implicit ones. + + -- The export_fvs make the exported names look just as if they + -- occurred in the source program. For the reasoning, see the + -- comments with RnIfaces.getImportVersions + export_fvs = mkNameSet (map availName export_avails) in slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls -> let @@ -424,7 +431,7 @@ vars of the source program, and extracts from the decl the gate names. getGates source_fvs (SigD (IfaceSig _ ty _ _)) = extractHsTyNames ty -getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _)) +getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _)) = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) (map getTyVarName tvs) `addOneToNameSet` cls) @@ -454,13 +461,13 @@ getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _)) (map getTyVarName tvs) `addOneToNameSet` tycon where - get (ConDecl n tvs ctxt details _) + get (ConDecl n _ tvs ctxt details _) | n `elemNameSet` source_fvs -- If the constructor is method, get fvs from all its fields = delListFromNameSet (get_details details `plusFV` extractHsCtxtTyNames ctxt) (map getTyVarName tvs) - get (ConDecl n tvs ctxt (RecCon fields) _) + get (ConDecl n _ tvs ctxt (RecCon fields) _) -- Even if the constructor isn't mentioned, the fields -- might be, as selectors. They can't mention existentially -- bound tyvars (typechecker checks for that) so no need for @@ -526,12 +533,28 @@ reportUnusedNames gbl_env avail_env (ExportEnv export_avails _ _) mentioned_name -- Now, a use of C implies a use of T, -- if C was brought into scope by T(..) or T(C) really_used_names = used_names `unionNameSets` - mkNameSet [ availName avail - | sub_name <- nameSetToList used_names, - let avail = case lookupNameEnv avail_env sub_name of - Just avail -> avail - Nothing -> WARN( True, text "reportUnusedName: not in avail_env" <+> ppr sub_name ) - Avail sub_name + mkNameSet [ availName parent_avail + | sub_name <- nameSetToList used_names + , isValOcc (getOccName sub_name) + + -- Usually, every used name will appear in avail_env, but there + -- is one time when it doesn't: tuples and other built in syntax. When you + -- write (a,b) that gives rise to a *use* of "(,)", so that the + -- instances will get pulled in, but the tycon "(,)" isn't actually + -- in scope. Hence the isValOcc filter. + -- + -- Also, (-x) gives rise to an implicit use of 'negate'; similarly, + -- 3.5 gives rise to an implcit use of :% + -- hence the isUserImportedName filter on the warning + + , let parent_avail + = case lookupNameEnv avail_env sub_name of + Just avail -> avail + Nothing -> WARN( isUserImportedName sub_name, + text "reportUnusedName: not in avail_env" <+> ppr sub_name ) + Avail sub_name + + , case parent_avail of { AvailTC _ _ -> True; other -> False } ] defined_names = mkNameSet (concat (rdrEnvElts gbl_env)) diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index eef2204045..aefb9ec051 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -233,7 +233,8 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs $ \ new_mbinders -> let - binder_set = mkNameSet new_mbinders + binder_set = mkNameSet new_mbinders + binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders] -- Weed out the fixity declarations that do not -- apply to any of the binders in this group. @@ -242,9 +243,6 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds forLocalBind (FixSig sig@(FixitySig name _ _ )) = isJust (lookupFM binder_occ_fm (rdrNameOcc name)) forLocalBind _ = True - - binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders] - in -- Rename the signatures renameSigs False binder_set diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index a4c7e7d3e5..65bf0f8367 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -177,20 +177,21 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) Just ty -> extractHsTyRdrNames ty tyvars_in_pats = extractPatsTyVars pats forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs - doc = text "a pattern type-signature" + doc_sig = text "a pattern type-signature" + doc_pats = text "in a pattern match" in - bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ sig_tyvars -> + bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars) $ \ sig_tyvars -> -- Note that we do a single bindLocalsRn for all the -- matches together, so that we spot the repeated variable in -- f x x = 1 - bindLocalsFVRn doc (collectPatsBinders pats) $ \ new_binders -> + bindLocalsFVRn doc_pats (collectPatsBinders pats) $ \ new_binders -> mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) -> rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> (case maybe_rhs_sig of Nothing -> returnRn (Nothing, emptyFVs) - Just ty | opt_GlasgowExts -> rnHsType doc ty `thenRn` \ (ty', ty_fvs) -> + Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) -> returnRn (Just ty', ty_fvs) | otherwise -> addErrRn (patSigErr ty) `thenRn_` returnRn (Nothing, emptyFVs) @@ -347,13 +348,13 @@ rnExpr section@(SectionR op expr) checkSectionPrec "right" section op' expr' `thenRn_` returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr) -rnExpr (CCall fun args may_gc is_casm fake_result_ty) +rnExpr (HsCCall fun args may_gc is_casm fake_result_ty) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc -> lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr -> lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io -> rnExprs args `thenRn` \ (args', fvs_args) -> - returnRn (CCall fun args' may_gc is_casm fake_result_ty, + returnRn (HsCCall fun args' may_gc is_casm fake_result_ty, fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io) rnExpr (HsSCC lbl expr) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 2715924203..6b1b90c627 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -22,7 +22,7 @@ module RnIfaces ( import CmdLineOpts ( opt_NoPruneDecls, opt_IgnoreIfacePragmas ) import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..), HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..), - ForeignDecl(..), ForKind(..), isDynamic, + ForeignDecl(..), ForKind(..), isDynamicExtName, FixitySig(..), RuleDecl(..), isClassOpSig, Deprecation(..) ) @@ -678,51 +678,47 @@ moudule is; that is, what it must record in its interface file as the things it uses. It records: \begin{itemize} -\item anything reachable from its body code -\item any module exported with a @module Foo@. +\item (a) anything reachable from its body code +\item (b) any module exported with a @module Foo@ +\item (c) anything reachable from an exported item \end{itemize} -% -Why the latter? Because if @Foo@ changes then this module's export list + +Why (b)? Because if @Foo@ changes then this module's export list will change, so we must recompile this module at least as far as making a new interface file --- but in practice that means complete recompilation. -What about this? +Why (c)? Consider this: \begin{verbatim} module A( f, g ) where | module B( f ) where import B( f ) | f = h 3 g = ... | h = ... \end{verbatim} -Should we record @B.f@ in @A@'s usages? In fact we don't. Certainly, -if anything about @B.f@ changes than anyone who imports @A@ should be -recompiled; they'll get an early exit if they don't use @B.f@. -However, even if @B.f@ doesn't change at all, @B.h@ may do so, and -this change may not be reflected in @f@'s version number. So there -are two things going on when compiling module @A@: - -\begin{enumerate} -\item Are @A.o@ and @A.hi@ correct? Then we can bale out early. -\item Should modules that import @A@ be recompiled? -\end{enumerate} - -For (1) it is slightly harmful to record @B.f@ in @A@'s usages, -because a change in @B.f@'s version will provoke full recompilation of -@A@, producing an identical @A.o@, and @A.hi@ differing only in its -usage-version of @B.f@ (and this usage-version info isn't used by any -importer). - -For (2), because of the tricky @B.h@ question above, we ensure that -@A.hi@ is touched (even if identical to its previous version) if A's -recompilation was triggered by an imported @.hi@ file date change. -Given that, there's no need to record @B.f@ in @A@'s usages. - -On the other hand, if @A@ exports @module B@, then we {\em do} count -@module B@ among @A@'s usages, because we must recompile @A@ to ensure -that @A.hi@ changes appropriately. - -HOWEVER, we *do* record the usage - import B <n> :: ; +Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in +@A@'s usages? Our idea is that we aren't going to touch A.hi if it is +*identical* to what it was before. If anything about @B.f@ changes +than anyone who imports @A@ should be recompiled in case they use +@B.f@ (they'll get an early exit if they don't). So, if anything +about @B.f@ changes we'd better make sure that something in A.hi +changes, and the convenient way to do that is to record the version +number @B.f@ in A.hi in the usage list. If B.f changes that'll force a +complete recompiation of A, which is overkill but it's the only way to +write a new, slightly different, A.hi. + +But the example is tricker. Even if @B.f@ doesn't change at all, +@B.h@ may do so, and this change may not be reflected in @f@'s version +number. But with -O, a module that imports A must be recompiled if +@B.h@ changes! So A must record a dependency on @B.h@. So we treat +the occurrence of @B.f@ in the export list *just as if* it were in the +code of A, and thereby haul in all the stuff reachable from it. + +[NB: If B was compiled with -O, but A isn't, we should really *still* +haul in all the unfoldings for B, in case the module that imports A *is* +compiled with -O. I think this is the case.] + +Even if B is used at all we get a usage line for B + import B <n> :: ... ; in A.hi, to record the fact that A does import B. This is used to decide to look to look for B.hi rather than B.hi-boot when compiling a module that imports A. This line says that A imports B, but uses nothing in it. @@ -733,7 +729,7 @@ getImportVersions :: ModuleName -- Name of this module -> ExportEnv -- Info about exports -> RnMG (VersionInfo Name) -- Version info for these names -getImportVersions this_mod (ExportEnv export_avails _ export_all_mods) +getImportVersions this_mod (ExportEnv _ _ export_all_mods) = getIfacesRn `thenRn` \ ifaces -> let mod_map = iImpModInfo ifaces @@ -813,6 +809,8 @@ getSlurped returnRn (iSlurp ifaces) recordSlurp maybe_version avail +-- Nothing for locally defined names +-- Just version for imported names = getIfacesRn `thenRn` \ ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = imp_names }) -> let @@ -856,7 +854,7 @@ getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> returnRn (Just (AvailTC tycon_name [tycon_name])) -getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ _ _ src_loc)) +getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ _ _ _ src_loc)) = new_name cname src_loc `thenRn` \ class_name -> -- Record the names for the class ops @@ -890,17 +888,17 @@ getDeclBinders new_name (RuleD _) = returnRn Nothing binds_haskell_name (FoImport _) _ = True binds_haskell_name FoLabel _ = True -binds_haskell_name FoExport ext_nm = isDynamic ext_nm +binds_haskell_name FoExport ext_nm = isDynamicExtName ext_nm ---------------- -getConFieldNames new_name (ConDecl con _ _ (RecCon fielddecls) src_loc : rest) +getConFieldNames new_name (ConDecl con _ _ _ (RecCon fielddecls) src_loc : rest) = mapRn (\n -> new_name n src_loc) (con:fields) `thenRn` \ cfs -> getConFieldNames new_name rest `thenRn` \ ns -> returnRn (cfs ++ ns) where fields = concat (map fst fielddecls) -getConFieldNames new_name (ConDecl con _ _ condecl src_loc : rest) +getConFieldNames new_name (ConDecl con _ _ _ condecl src_loc : rest) = new_name con src_loc `thenRn` \ n -> (case condecl of NewCon _ (Just f) -> @@ -925,11 +923,11 @@ and the dict fun of an instance decl, because both of these have bindings of their own elsewhere. \begin{code} -getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname snames src_loc)) - = new_name dname src_loc `thenRn` \ datacon_name -> - new_name tname src_loc `thenRn` \ tycon_name -> - sequenceRn [new_name n src_loc | n <- snames] `thenRn` \ scsel_names -> - returnRn (tycon_name : datacon_name : scsel_names) +getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname dwname snames src_loc)) + = sequenceRn [new_name n src_loc | n <- (tname : dname : dwname : snames)] + +getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _)) + = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons] getDeclSysBinders new_name other_decl = returnRn [] diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 832c925611..4ef7c0a5db 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -16,7 +16,7 @@ import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports, import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..), IE(..), ieName, - ForeignDecl(..), ForKind(..), isDynamic, + ForeignDecl(..), ForKind(..), isDynamicExtName, FixitySig(..), Sig(..), ImportDecl(..), collectTopBinders ) @@ -334,7 +334,7 @@ fixitiesFromLocalDecls gbl_env decls getFixities acc (FixD fix) = fix_decl acc fix - getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _)) + getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _)) = foldlRn fix_decl acc [sig | FixSig sig <- sigs] -- Get fixities from class decl sigs too. getFixities acc other_decl diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 0ef3d39e3b..1531d8c809 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -52,6 +52,8 @@ import SrcLoc ( SrcLoc ) import CmdLineOpts ( opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars import Unique ( Uniquable(..) ) import UniqFM ( lookupUFM ) +import ErrUtils ( Message ) +import CStrings ( isCLabelString ) import Maybes ( maybeToBool, catMaybes ) import Util \end{code} @@ -163,7 +165,7 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc)) syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas - tname dname snames src_loc)) + tname dname dwname snames src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn cname `thenRn` \ cname' -> @@ -177,6 +179,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas -- I can't work up the energy to do it more beautifully mkImportedGlobalFromRdrName tname `thenRn` \ tname' -> mkImportedGlobalFromRdrName dname `thenRn` \ dname' -> + mkImportedGlobalFromRdrName dwname `thenRn` \ dwname' -> mapRn mkImportedGlobalFromRdrName snames `thenRn` \ snames' -> -- Tyvars scope over bindings and context @@ -216,7 +219,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas ASSERT(isNoClassPragmas pragmas) returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds' - NoClassPragmas tname' dname' snames' src_loc), + NoClassPragmas tname' dname' dwname' snames' src_loc), sig_fvs `plusFV` fix_fvs `plusFV` cxt_fvs `plusFV` @@ -362,6 +365,10 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) = pushSrcLocRn src_loc $ lookupOccRn name `thenRn` \ name' -> let + ok_ext_nm Dynamic = True + ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb + ok_ext_nm (ExtName nm Nothing) = isCLabelString nm + fvs1 = case imp_exp of FoImport _ | not isDyn -> emptyFVs FoLabel -> emptyFVs @@ -371,12 +378,13 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) | otherwise -> mkNameSet [name'] _ -> emptyFVs in - rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) -> + checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_` + rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) -> returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), fvs1 `plusFV` fvs2) where fo_decl_msg = ptext SLIT("a foreign declaration") - isDyn = isDynamic ext_nm + isDyn = isDynamicExtName ext_nm \end{code} %********************************************************* @@ -447,17 +455,21 @@ rnDerivs (Just clss) \begin{code} conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) -conDeclName (ConDecl n _ _ _ l) = (n,l) +conDeclName (ConDecl n _ _ _ _ l) = (n,l) rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars) -rnConDecl (ConDecl name tvs cxt details locn) +rnConDecl (ConDecl name wkr tvs cxt details locn) = pushSrcLocRn locn $ checkConName name `thenRn_` lookupBndrRn name `thenRn` \ new_name -> + + mkImportedGlobalFromRdrName wkr `thenRn` \ new_wkr -> + -- See comments with ClassDecl + bindTyVarsFVRn doc tvs $ \ new_tyvars -> rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) -> rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) -> - returnRn (ConDecl new_name new_tyvars new_context new_details locn, + returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn, cxt_fvs `plusFV` det_fvs) where doc = text "the definition of data constructor" <+> quotes (ppr name) @@ -738,8 +750,8 @@ rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) -> returnRn (HsUnfold inline expr', fvs) rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs) rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs) -rnIdInfo (HsNoCafRefs) = returnRn (HsNoCafRefs, emptyFVs) -rnIdInfo (HsCprInfo cpr_info) = returnRn (HsCprInfo cpr_info, emptyFVs) +rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs) +rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs) rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body `thenRn` \ (rule_body', fvs) -> returnRn (HsSpecialise rule_body', fvs) @@ -762,10 +774,16 @@ rnCoreExpr (UfVar v) = lookupOccRn v `thenRn` \ v' -> returnRn (UfVar v', unitFV v') -rnCoreExpr (UfCon con args) - = rnUfCon con `thenRn` \ (con', fvs1) -> - mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) -> - returnRn (UfCon con' args', fvs1 `plusFV` fvs2) +rnCoreExpr (UfLit l) + = returnRn (UfLit l, emptyFVs) + +rnCoreExpr (UfLitLit l ty) + = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) -> + returnRn (UfLitLit l ty', fvs) + +rnCoreExpr (UfCCall cc ty) + = rnHsPolyType (text "ccall") ty `thenRn` \ (ty', fvs) -> + returnRn (UfCCall cc ty', fvs) rnCoreExpr (UfTuple con args) = lookupOccRn con `thenRn` \ con' -> @@ -853,23 +871,16 @@ rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs) rnUfCon UfDefault = returnRn (UfDefault, emptyFVs) -rnUfCon (UfDataCon con) +rnUfCon (UfDataAlt con) = lookupOccRn con `thenRn` \ con' -> - returnRn (UfDataCon con', unitFV con') + returnRn (UfDataAlt con', unitFV con') -rnUfCon (UfLitCon lit) - = returnRn (UfLitCon lit, emptyFVs) +rnUfCon (UfLitAlt lit) + = returnRn (UfLitAlt lit, emptyFVs) -rnUfCon (UfLitLitCon lit ty) +rnUfCon (UfLitLitAlt lit ty) = rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) -> - returnRn (UfLitLitCon lit ty', fvs) - -rnUfCon (UfPrimOp op) - = lookupOccRn op `thenRn` \ op' -> - returnRn (UfPrimOp op', emptyFVs) - -rnUfCon (UfCCallOp str is_dyn casm gc) - = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs) + returnRn (UfLitLitAlt lit ty', fvs) \end{code} %********************************************************* @@ -972,4 +983,8 @@ badRuleVar name var = sep [ptext SLIT("Rule") <+> ptext name <> colon, ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> ptext SLIT("does not appear on left hand side")] + +badExtName :: ExtName -> Message +badExtName ext_nm + = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")] \end{code} diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs index d424653075..651165dd0a 100644 --- a/ghc/compiler/simplCore/CSE.lhs +++ b/ghc/compiler/simplCore/CSE.lhs @@ -13,7 +13,7 @@ module CSE ( import CmdLineOpts ( opt_D_dump_cse, opt_D_verbose_core2core ) import Id ( Id, idType ) import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig ) -import Const ( isBoxedDataCon ) +import DataCon ( isUnboxedTupleCon ) import Type ( splitTyConApp_maybe ) import CoreSyn import VarEnv @@ -132,19 +132,15 @@ tryForCSE env expr = case lookupCSEnv env expr' of where expr' = cseExpr env expr - cseExpr :: CSEnv -> CoreExpr -> CoreExpr +cseExpr env (Type t) = Type t +cseExpr env (Lit lit) = Lit lit cseExpr env (Var v) = Var (lookupSubst env v) -cseExpr env (App f (Type t)) = App (cseExpr env f) (Type t) cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) -cseExpr env expr@(Con con args) = case lookupCSEnv env expr of - Just id -> Var id - Nothing -> Con con [tryForCSE env arg | arg <- args] cseExpr env (Note n e) = Note n (cseExpr env e) cseExpr env (Lam b e) = Lam b (cseExpr env e) cseExpr env (Let bind e) = let (env1, bind') = cseBind env bind in Let bind' (cseExpr env1 e) -cseExpr env (Type t) = Type t cseExpr env (Case scrut bndr alts) = Case scrut' bndr (cseAlts env scrut' bndr alts) where scrut' = tryForCSE env scrut @@ -162,19 +158,23 @@ cseAlts env new_scrut bndr alts -- map: new_scrut -> bndr arg_tys = case splitTyConApp_maybe (idType bndr) of - Just (_, arg_tys) -> map Type arg_tys + Just (_, arg_tys) -> arg_tys other -> pprPanic "cseAlts" (ppr bndr) - cse_alt (con, args, rhs) - | null args || not (isBoxedDataCon con) = (con, args, cseExpr alt_env rhs) + cse_alt (DataAlt con, args, rhs) + | not (null args || isUnboxedTupleCon con) -- Don't try CSE if there are no args; it just increases the number -- of live vars. E.g. -- case x of { True -> ....True.... } -- Don't replace True by x! -- Hence the 'null args', which also deal with literals and DEFAULT -- And we can't CSE on unboxed tuples - | otherwise - = (con, args, cseExpr (extendCSEnv alt_env con_target (Con con (arg_tys ++ (map varToCoreExpr args)))) rhs) + = (DataAlt con, args, tryForCSE new_env rhs) + where + new_env = extendCSEnv alt_env con_target (mkAltExpr (DataAlt con) args arg_tys) + + cse_alt (con, args, rhs) + = (con, args, tryForCSE alt_env rhs) \end{code} diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs deleted file mode 100644 index fe8186f607..0000000000 --- a/ghc/compiler/simplCore/ConFold.lhs +++ /dev/null @@ -1,312 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[ConFold]{Constant Folder} - -ToDo: - check boundaries before folding, e.g. we can fold the Float addition - (i1 + i2) only if it results in a valid Float. - -\begin{code} -module ConFold ( tryPrimOp ) where - -#include "HsVersions.h" - -import CoreSyn -import Id ( getIdUnfolding ) -import Const ( mkMachInt, mkMachWord, Literal(..), Con(..) ) -import PrimOp ( PrimOp(..) ) -import SimplMonad -import TysWiredIn ( trueDataCon, falseDataCon ) -import TyCon ( tyConDataCons, isEnumerationTyCon, isNewTyCon ) -import DataCon ( dataConTag, dataConTyCon, fIRST_TAG ) -import Const ( conOkForAlt ) -import CoreUnfold ( maybeUnfoldingTemplate ) -import CoreUtils ( exprIsValue ) -import Type ( splitTyConApp_maybe ) - -import Maybes ( maybeToBool ) -import Char ( ord, chr ) -import Outputable - -#if __GLASGOW_HASKELL__ >= 404 -import GlaExts ( fromInt ) -#endif -\end{code} - -\begin{code} -tryPrimOp :: PrimOp -> [CoreArg] -- op arg1 ... argn - -- Args are already simplified - -> Maybe CoreExpr -- Nothing => no transformation - -- Just e => transforms to e -\end{code} - -In the parallel world, we use _seq_ to control the order in which -certain expressions will be evaluated. Operationally, the expression -``_seq_ a b'' evaluates a and then evaluates b. We have an inlining -for _seq_ which translates _seq_ to: - - _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y } - -Now, we know that the seq# primitive will never return 0#, but we -don't let the simplifier know that. We also use a special error -value, parError#, which is *not* a bottoming Id, so as far as the -simplifier is concerned, we have to evaluate seq# a before we know -whether or not y will be evaluated. - -If we didn't have the extra case, then after inlining the compiler might -see: - f p q = case seq# p of { _ -> p+q } - -If it sees that, it can see that f is strict in q, and hence it might -evaluate q before p! The "0# ->" case prevents this happening. -By having the parError# branch we make sure that anything in the -other branch stays there! - -This is fine, but we'd like to get rid of the extraneous code. Hence, -we *do* let the simplifier know that seq# is strict in its argument. -As a result, we hope that `a' will be evaluated before seq# is called. -At this point, we have a very special and magical simpification which -says that ``seq# a'' can be immediately simplified to `1#' if we -know that `a' is already evaluated. - -NB: If we ever do case-floating, we have an extra worry: - - case a of - a' -> let b' = case seq# a of { True -> b; False -> parError# } - in case b' of ... - - => - - case a of - a' -> let b' = case True of { True -> b; False -> parError# } - in case b' of ... - - => - - case a of - a' -> let b' = b - in case b' of ... - - => - - case a of - a' -> case b of ... - -The second case must never be floated outside of the first! - -\begin{code} -tryPrimOp SeqOp [Type ty, arg] - | exprIsValue arg - = Just (Con (Literal (mkMachInt 1)) []) -\end{code} - -\begin{code} -tryPrimOp TagToEnumOp [Type ty, Con (Literal (MachInt i _)) _] - | isEnumerationTyCon tycon = Just (Con (DataCon dc) []) - | otherwise = panic "tryPrimOp: tagToEnum# on non-enumeration type" - where tag = fromInteger i - constrs = tyConDataCons tycon - (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc - fIRST_TAG ] - (Just (tycon,_)) = splitTyConApp_maybe ty -\end{code} - -For dataToTag#, we can reduce if either - - (a) the argument is a constructor - (b) the argument is a variable whose unfolding is a known constructor - -\begin{code} -tryPrimOp DataToTagOp [Type ty, Con (DataCon dc) _] - = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) []) -tryPrimOp DataToTagOp [Type ty, Var x] - | maybeToBool maybe_constr - = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) - Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) []) - where - maybe_constr = case maybeUnfoldingTemplate (getIdUnfolding x) of - Just (Con (DataCon dc) _) -> Just dc - other -> Nothing - Just dc = maybe_constr -\end{code} - -\begin{code} -tryPrimOp op args - = case args of - [Con (Literal (MachChar char_lit)) _] -> oneCharLit op char_lit - [Con (Literal (MachInt int_lit signed)) _] -> (if signed then oneIntLit else oneWordLit) - op int_lit - [Con (Literal (MachFloat float_lit)) _] -> oneFloatLit op float_lit - [Con (Literal (MachDouble double_lit)) _] -> oneDoubleLit op double_lit - [Con (Literal other_lit) _] -> oneLit op other_lit - - [Con (Literal (MachChar char_lit1)) _, - Con (Literal (MachChar char_lit2)) _] -> twoCharLits op char_lit1 char_lit2 - - [Con (Literal (MachInt int_lit1 True)) _, -- both *signed* literals - Con (Literal (MachInt int_lit2 True)) _] -> twoIntLits op int_lit1 int_lit2 - - [Con (Literal (MachInt int_lit1 False)) _, -- both *unsigned* literals - Con (Literal (MachInt int_lit2 False)) _] -> twoWordLits op int_lit1 int_lit2 - - [Con (Literal (MachInt int_lit1 False)) _, -- unsigned+signed (shift ops) - Con (Literal (MachInt int_lit2 True)) _] -> oneWordOneIntLit op int_lit1 int_lit2 - - [Con (Literal (MachFloat float_lit1)) _, - Con (Literal (MachFloat float_lit2)) _] -> twoFloatLits op float_lit1 float_lit2 - - [Con (Literal (MachDouble double_lit1)) _, - Con (Literal (MachDouble double_lit2)) _] -> twoDoubleLits op double_lit1 double_lit2 - - [Con (Literal lit) _, Var var] -> litVar op lit var - [Var var, Con (Literal lit) _] -> litVar op lit var - - other -> give_up - where - give_up = Nothing - - return_char c = Just (Con (Literal (MachChar c)) []) - return_int i = Just (Con (Literal (mkMachInt i)) []) - return_word i = Just (Con (Literal (mkMachWord i)) []) - return_float f = Just (Con (Literal (MachFloat f)) []) - return_double d = Just (Con (Literal (MachDouble d)) []) - return_lit lit = Just (Con (Literal lit) []) - - return_bool True = Just trueVal - return_bool False = Just falseVal - - return_prim_case var lit val_if_eq val_if_neq - = Just (Case (Var var) var [(Literal lit, [], val_if_eq), - (DEFAULT, [], val_if_neq)]) - - --------- Ints -------------- - oneIntLit IntNegOp i = return_int (-i) - oneIntLit ChrOp i = return_char (chr (fromInteger i)) --- SIGH: these two cause trouble in unfoldery --- as we can't distinguish unsigned literals in interfaces (ToDo?) --- oneIntLit Int2WordOp i = ASSERT( i>=0 ) return_word i --- oneIntLit Int2AddrOp i = ASSERT( i>=0 ) return_lit (MachAddr i) - oneIntLit Int2FloatOp i = return_float (fromInteger i) - oneIntLit Int2DoubleOp i = return_double (fromInteger i) - oneIntLit _ _ = {-trace "oneIntLit: giving up"-} give_up - - oneWordLit Word2IntOp w = {-lazy:ASSERT( w<= maxInt)-} return_int w --- oneWordLit NotOp w = ??? ToDo: sort-of a pain - oneWordLit _ _ = {-trace "oneIntLit: giving up"-} give_up - - twoIntLits IntAddOp i1 i2 = checkRange (i1+i2) - twoIntLits IntSubOp i1 i2 = checkRange (i1-i2) - twoIntLits IntMulOp i1 i2 = checkRange (i1*i2) - twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2) - twoIntLits IntRemOp i1 i2 | i2 /= 0 = return_int (i1 `rem` i2) - twoIntLits IntGtOp i1 i2 = return_bool (i1 > i2) - twoIntLits IntGeOp i1 i2 = return_bool (i1 >= i2) - twoIntLits IntEqOp i1 i2 = return_bool (i1 == i2) - twoIntLits IntNeOp i1 i2 = return_bool (i1 /= i2) - twoIntLits IntLtOp i1 i2 = return_bool (i1 < i2) - twoIntLits IntLeOp i1 i2 = return_bool (i1 <= i2) - -- ToDo: something for integer-shift ops? - twoIntLits _ _ _ = give_up - - twoWordLits WordGtOp w1 w2 = return_bool (w1 > w2) - twoWordLits WordGeOp w1 w2 = return_bool (w1 >= w2) - twoWordLits WordEqOp w1 w2 = return_bool (w1 == w2) - twoWordLits WordNeOp w1 w2 = return_bool (w1 /= w2) - twoWordLits WordLtOp w1 w2 = return_bool (w1 < w2) - twoWordLits WordLeOp w1 w2 = return_bool (w1 <= w2) - -- ToDo: something for AndOp, OrOp? - twoWordLits _ _ _ = give_up - - -- ToDo: something for shifts - oneWordOneIntLit _ _ _ = give_up - - --------- Floats -------------- - oneFloatLit FloatNegOp f = return_float (-f) - -- hard to do float ops in Rationals ?? (WDP 94/10) ToDo - oneFloatLit _ _ = give_up - - twoFloatLits FloatGtOp f1 f2 = return_bool (f1 > f2) - twoFloatLits FloatGeOp f1 f2 = return_bool (f1 >= f2) - twoFloatLits FloatEqOp f1 f2 = return_bool (f1 == f2) - twoFloatLits FloatNeOp f1 f2 = return_bool (f1 /= f2) - twoFloatLits FloatLtOp f1 f2 = return_bool (f1 < f2) - twoFloatLits FloatLeOp f1 f2 = return_bool (f1 <= f2) - twoFloatLits FloatAddOp f1 f2 = return_float (f1 + f2) - twoFloatLits FloatSubOp f1 f2 = return_float (f1 - f2) - twoFloatLits FloatMulOp f1 f2 = return_float (f1 * f2) - twoFloatLits FloatDivOp f1 f2 | f2 /= 0 = return_float (f1 / f2) - twoFloatLits _ _ _ = give_up - - --------- Doubles -------------- - oneDoubleLit DoubleNegOp d = return_double (-d) - oneDoubleLit _ _ = give_up - - twoDoubleLits DoubleGtOp d1 d2 = return_bool (d1 > d2) - twoDoubleLits DoubleGeOp d1 d2 = return_bool (d1 >= d2) - twoDoubleLits DoubleEqOp d1 d2 = return_bool (d1 == d2) - twoDoubleLits DoubleNeOp d1 d2 = return_bool (d1 /= d2) - twoDoubleLits DoubleLtOp d1 d2 = return_bool (d1 < d2) - twoDoubleLits DoubleLeOp d1 d2 = return_bool (d1 <= d2) - twoDoubleLits DoubleAddOp d1 d2 = return_double (d1 + d2) - twoDoubleLits DoubleSubOp d1 d2 = return_double (d1 - d2) - twoDoubleLits DoubleMulOp d1 d2 = return_double (d1 * d2) - twoDoubleLits DoubleDivOp d1 d2 | d2 /= 0 = return_double (d1 / d2) - twoDoubleLits _ _ _ = give_up - - --------- Characters -------------- - oneCharLit OrdOp c = return_int (fromInt (ord c)) - oneCharLit _ _ = give_up - - twoCharLits CharGtOp c1 c2 = return_bool (c1 > c2) - twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2) - twoCharLits CharEqOp c1 c2 = return_bool (c1 == c2) - twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2) - twoCharLits CharLtOp c1 c2 = return_bool (c1 < c2) - twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2) - twoCharLits _ _ _ = give_up - - --------- Miscellaneous -------------- - oneLit Addr2IntOp (MachAddr i) = return_int (fromInteger i) - oneLit op lit = give_up - - --------- Equality and inequality for Int/Char -------------- - -- This stuff turns - -- n ==# 3# - -- into - -- case n of - -- 3# -> True - -- m -> False - -- - -- This is a Good Thing, because it allows case-of case things - -- to happen, and case-default absorption to happen. For - -- example: - -- - -- if (n ==# 3#) || (n ==# 4#) then e1 else e2 - -- will transform to - -- case n of - -- 3# -> e1 - -- 4# -> e1 - -- m -> e2 - -- (modulo the usual precautions to avoid duplicating e1) - - litVar IntEqOp lit var = return_prim_case var lit trueVal falseVal - litVar IntNeOp lit var = return_prim_case var lit falseVal trueVal - litVar CharEqOp lit var = return_prim_case var lit trueVal falseVal - litVar CharNeOp lit var = return_prim_case var lit falseVal trueVal - litVar other_op lit var = give_up - - - checkRange :: Integer -> Maybe CoreExpr - checkRange val - | (val > fromInt maxInt) || (val < fromInt minInt) = - -- Better tell the user that we've overflowed... - pprTrace "Warning:" (text "Integer overflow in expression: " <> - ppr ((mkPrimApp op args)::CoreExpr)) $ - -- ..not that it stops us from actually folding! - -- ToDo: a SrcLoc would be nice. - return_int val - | otherwise = return_int val - -trueVal = Con (DataCon trueDataCon) [] -falseVal = Con (DataCon falseDataCon) [] -\end{code} diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 97e1c06aad..52250b4dba 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -18,14 +18,14 @@ module FloatIn ( floatInwards ) where import CmdLineOpts ( opt_D_verbose_core2core ) import CoreSyn +import CoreUtils ( exprIsValue, exprIsDupable ) import CoreLint ( beginPass, endPass ) -import Const ( isDataCon ) import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf ) import Id ( isOneShotLambda ) import Var ( Id, idType, isTyVar ) import Type ( isUnLiftedType ) import VarSet -import Util ( zipEqual ) +import Util ( zipEqual, zipWithEqual ) import Outputable \end{code} @@ -141,16 +141,7 @@ fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty -fiExpr to_drop (_, AnnCon c args) - | isDataCon c -- Don't float into the args of a data construtor; - -- the simplifier will float straight back out - = mkCoLets' to_drop (Con c (map (fiExpr []) args)) - - | otherwise - = mkCoLets' drop_here (Con c args') - where - (drop_here : arg_drops) = sepBindsByDropPoint (map freeVarsOf args) to_drop - args' = zipWith fiExpr arg_drops args +fiExpr to_drop (_, AnnLit lit) = Lit lit \end{code} Applications: we do float inside applications, mainly because we @@ -161,7 +152,7 @@ pull out any silly ones. fiExpr to_drop (_,AnnApp fun arg) = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg)) where - [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint [freeVarsOf fun, freeVarsOf arg] to_drop + [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop \end{code} We are careful about lambdas: @@ -265,7 +256,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) -- No point in floating in only to float straight out again -- Ditto ok-for-speculation unlifted RHSs - [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint [rhs_fvs, final_body_fvs] to_drop + [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint False [rhs_fvs, final_body_fvs] to_drop new_to_drop = body_binds ++ -- the bindings used only in the body [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself @@ -301,7 +292,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs | otherwise = emptyVarSet - (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint (final_body_fvs:rhss_fvs) to_drop + (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint False (final_body_fvs:rhss_fvs) to_drop new_to_drop = -- the bindings used only in the body body_binds ++ @@ -329,12 +320,20 @@ alternatives/default [default FVs always {\em first}!]. \begin{code} fiExpr to_drop (_, AnnCase scrut case_bndr alts) - = mkCoLets' drop_here (Case (fiExpr scrut_drops scrut) case_bndr - (zipWith fi_alt alts_drops alts)) + = mkCoLets' drop_here1 $ + mkCoLets' drop_here2 $ + Case (fiExpr scrut_drops scrut) case_bndr + (zipWith fi_alt alts_drops_s alts) where - (drop_here : scrut_drops : alts_drops) = sepBindsByDropPoint (scrut_fvs : alts_fvs) to_drop - scrut_fvs = freeVarsOf scrut - alts_fvs = map alt_fvs alts + -- Float into the scrut and alts-considered-together just like App + [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop + + -- Float into the alts with the is_case flag set + (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops + + scrut_fvs = freeVarsOf scrut + alts_fvs = map alt_fvs alts + all_alts_fvs = unionVarSets alts_fvs alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args) -- Delete case_bndr and args from free vars of rhs -- to get free vars of alt @@ -351,8 +350,8 @@ noFloatIntoRhs (AnnLam b _) = not (isId b && isOneShotLambda b) -- If x is used only in the error case join point, j, we must float the -- boxing constructor into it, else we box it every time which is very bad -- news indeed. -noFloatIntoRhs (AnnCon con _) = isDataCon con -noFloatIntoRhs other = False + +noFloatIntoRhs rhs = exprIsValue (deAnnotate' rhs) -- We'd just float rigt back out again... \end{code} @@ -379,7 +378,8 @@ We have to maintain the order on these drop-point-related lists. \begin{code} sepBindsByDropPoint - :: [FreeVarsSet] -- One set of FVs per drop point + :: Bool -- True <=> is case expression + -> [FreeVarsSet] -- One set of FVs per drop point -> FloatingBinds -- Candidate floaters -> [FloatingBinds] -- FIRST one is bindings which must not be floated -- inside any drop point; the rest correspond @@ -391,38 +391,60 @@ sepBindsByDropPoint -- a binding (let x = E in B) might have a specialised version of -- x (say x') stored inside x, but x' isn't free in E or B. -sepBindsByDropPoint drop_pts [] +type DropBox = (FreeVarsSet, FloatingBinds) + +sepBindsByDropPoint is_case drop_pts [] = [] : [[] | p <- drop_pts] -- cut to the chase scene; it happens -sepBindsByDropPoint drop_pts floaters +sepBindsByDropPoint is_case drop_pts floaters = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts)) where - go :: FloatingBinds -> [(FreeVarsSet, FloatingBinds)] -> [FloatingBinds] + go :: FloatingBinds -> [DropBox] -> [FloatingBinds] -- The *first* one in the argument list is the drop_here set -- The FloatingBinds in the lists are in the reverse of -- the normal FloatingBinds order; that is, they are the right way round! go [] drop_boxes = map (reverse . snd) drop_boxes - go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes - = go binds (insert drop_boxes (drop_here : used_in_flags)) - -- insert puts the find in box whose True flag comes first + go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes) + = go binds new_boxes where + -- "here" means the group of bindings dropped at the top of the fork + (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind) | (fvs, drops) <- drop_boxes] - drop_here = used_here || not (exactlyOneTrue used_in_flags) + drop_here = used_here || not can_push + + -- For case expressions we duplicate the binding if it is + -- reasonably small, and if it is not used in all the RHSs + -- This is good for situations like + -- let x = I# y in + -- case e of + -- C -> error x + -- D -> error x + -- E -> ...not mentioning x... - insert ((fvs,drops) : drop_boxes) (True : _) - = ((fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) : drop_boxes) - insert (drop_box : drop_boxes) (False : others) - = drop_box : insert drop_boxes others - insert _ _ = panic "sepBindsByDropPoint" -- Should never happen + n_alts = length used_in_flags + n_used_alts = length [() | True <- used_in_flags] + + can_push = n_used_alts == 1 -- Used in just one branch + || (is_case && -- We are looking at case alternatives + n_used_alts > 1 && -- It's used in more than one + n_used_alts < n_alts && -- ...but not all + bindIsDupable bind) -- and we can duplicate the binding + + new_boxes | drop_here = (insert here_box : fork_boxes) + | otherwise = (here_box : new_fork_boxes) + + new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags + + insert :: DropBox -> DropBox + insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) + + insert_maybe box True = insert box + insert_maybe box False = box -exactlyOneTrue :: [Bool] -> Bool -exactlyOneTrue flags = case [() | True <- flags] of - [_] -> True - other -> False floatedBindsFVs :: FloatingBinds -> FreeVarsSet floatedBindsFVs binds = unionVarSets (map snd binds) @@ -430,4 +452,7 @@ floatedBindsFVs binds = unionVarSets (map snd binds) mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop -- Remember to_drop is in *reverse* dependency order + +bindIsDupable (Rec prs) = all (exprIsDupable . snd) prs +bindIsDupable (NonRec b r) = exprIsDupable r \end{code} diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index 83e5d5a6f1..c929be3370 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -11,12 +11,12 @@ module FloatOut ( floatOutwards ) where #include "HsVersions.h" import CoreSyn +import CoreUtils ( mkSCC ) import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_simpl_stats ) import ErrUtils ( dumpIfSet ) import CostCentre ( dupifyCC, CostCentre ) import Id ( Id, idType ) -import Const ( isWHNFCon ) import VarEnv import CoreLint ( beginPass, endPass ) import PprCore @@ -77,13 +77,15 @@ type FloatBinds = [FloatBind] %************************************************************************ \begin{code} -floatOutwards :: UniqSupply -> [CoreBind] -> IO [CoreBind] +floatOutwards :: Bool -- True <=> float lambdas to top level + -> UniqSupply + -> [CoreBind] -> IO [CoreBind] -floatOutwards us pgm +floatOutwards float_lams us pgm = do { - beginPass "Float out"; + beginPass float_msg ; - let { annotated_w_levels = setLevels pgm us ; + let { annotated_w_levels = setLevels float_lams pgm us ; (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) } ; @@ -97,10 +99,13 @@ floatOutwards us pgm int ntlets, ptext SLIT(" Lets floated elsewhere; from "), int lams, ptext SLIT(" Lambda groups")]); - endPass "Float out" + endPass float_msg opt_D_verbose_core2core {- no specific flag for dumping float-out -} (concat binds_s') } + where + float_msg | float_lams = "Float out (floating lambdas too)" + | otherwise = "Float out (not floating lambdas)" floatTopBind bind@(NonRec _ _) = case (floatBind emptyVarEnv tOP_LEVEL bind) of { (fs, floats, bind', _) -> @@ -200,9 +205,7 @@ floatRhs env lvl arg floatExpr env _ (Var v) = (zeroStats, [], Var v) floatExpr env _ (Type ty) = (zeroStats, [], Type ty) -floatExpr env lvl (Con con as) - = case floatList (floatRhs env lvl) as of { (stats, floats, as') -> - (stats, floats, Con con as') } +floatExpr env _ (Lit lit) = (zeroStats, [], Lit lit) floatExpr env lvl (App e a) = case (floatExpr env lvl e) of { (fse, floats_e, e') -> @@ -250,17 +253,10 @@ floatExpr env lvl (Note note@(SCC cc) expr) = [ (level, ann_bind floater) | (level, floater) <- defn_groups ] where ann_bind (NonRec binder rhs) - = NonRec binder (ann_rhs rhs) + = NonRec binder (mkSCC dupd_cc rhs) ann_bind (Rec pairs) - = Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs] - - ann_rhs (Lam arg e) = Lam arg (ann_rhs e) - ann_rhs rhs@(Con con _) | isWHNFCon con = rhs -- no point in scc'ing WHNF data - ann_rhs rhs = Note (SCC dupd_cc) rhs - - -- Note: Nested SCC's are preserved for the benefit of - -- cost centre stack profiling (Durham) + = Rec [(binder, mkSCC dupd_cc rhs) | (binder, rhs) <- pairs] -- At one time I tried the effect of not float anything out of an InlineMe, -- but it sometimes works badly. For example, consider PrelArr.done. It diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index bb9a08f138..f70b692ac7 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -11,7 +11,7 @@ module LiberateCase ( liberateCase ) where import CmdLineOpts ( opt_D_verbose_core2core, opt_LiberateCaseThreshold ) import CoreLint ( beginPass, endPass ) import CoreSyn -import CoreUnfold ( calcUnfoldingGuidance, couldBeSmallEnoughToInline ) +import CoreUnfold ( couldBeSmallEnoughToInline ) import Var ( Id ) import VarEnv import Maybes @@ -208,8 +208,7 @@ libCaseBind env (Rec pairs) -- -- [May 98: all this is now handled by SimplCore.tidyCore] - rhs_small_enough rhs - = couldBeSmallEnoughToInline (calcUnfoldingGuidance lIBERATE_BOMB_SIZE rhs) + rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs lIBERATE_BOMB_SIZE = bombOutSize env \end{code} @@ -224,9 +223,9 @@ libCase :: LibCaseEnv -> CoreExpr libCase env (Var v) = libCaseId env v +libCase env (Lit lit) = Lit lit libCase env (Type ty) = Type ty libCase env (App fun arg) = App (libCase env fun) (libCase env arg) -libCase env (Con con args) = Con con (map (libCase env) args) libCase env (Note note body) = Note note (libCase env body) libCase env (Lam binder body) diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index e4fb5b8fe5..5a7fd195a8 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -24,11 +24,11 @@ import CmdLineOpts ( SimplifierSwitch(..) ) import CoreSyn import CoreFVs ( idRuleVars ) import CoreUtils ( exprIsTrivial ) -import Const ( Con(..), Literal(..) ) -import Id ( isSpecPragmaId, isOneShotLambda, setOneShotLambda, - getIdOccInfo, setIdOccInfo, +import Literal ( Literal(..) ) +import Id ( isSpecPragmaId, isDataConId, isOneShotLambda, setOneShotLambda, + idOccInfo, setIdOccInfo, isExportedId, modifyIdInfo, idInfo, - getIdSpecialisation, + idSpecialisation, idType, idUnique, Id ) import IdInfo ( OccInfo(..), insideLam, copyIdInfo ) @@ -451,14 +451,14 @@ reOrderRec env (CyclicSCC (bind : binds)) not (isExportedId bndr) = 3 -- Practically certain to be inlined | inlineCandidate bndr rhs = 3 -- Likely to be inlined | not_fun_ty (idType bndr) = 2 -- Data types help with cases - | not (isEmptyCoreRules (getIdSpecialisation bndr)) = 1 + | not (isEmptyCoreRules (idSpecialisation bndr)) = 1 -- Avoid things with specialisations; we'd like -- to take advantage of them in the subsequent bindings | otherwise = 0 inlineCandidate :: Id -> CoreExpr -> Bool inlineCandidate id (Note InlineMe _) = True - inlineCandidate id rhs = case getIdOccInfo id of + inlineCandidate id rhs = case idOccInfo id of OneOcc _ _ -> True other -> False @@ -551,35 +551,7 @@ If we aren't careful we duplicate the (expensive x) call! Constructors are rather like lambdas in this way. \begin{code} - -- For NoRep literals we have to report an occurrence of - -- the things which tidyCore will later add, so that when - -- we are compiling the very module in which those thin-air Ids - -- are defined we have them in scope! -occAnal env expr@(Con (Literal lit) args) - = ASSERT( null args ) - (mk_lit_uds lit, expr) - where - mk_lit_uds (NoRepStr _ _) = try noRepStrIds - mk_lit_uds (NoRepInteger _ _) = try noRepIntegerIds - mk_lit_uds lit = emptyDetails - - try vs = foldr add emptyDetails vs - add v uds | isCandidate env v = extendVarEnv uds v funOccZero - | otherwise = uds - -occAnal env (Con con args) - = case occAnalArgs env args of { (arg_uds, args') -> - let - -- We mark the free vars of the argument of a constructor as "many" - -- This means that nothing gets inlined into a constructor argument - -- position, which is what we want. Typically those constructor - -- arguments are just variables, or trivial expressions. - final_arg_uds = case con of - DataCon _ -> mapVarEnv markMany arg_uds - other -> arg_uds - in - (final_arg_uds, Con con args') - } +occAnal env expr@(Lit lit) = (emptyDetails, expr) \end{code} \begin{code} @@ -699,8 +671,17 @@ occAnalApp env (Var fun, args) | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args + + | isDataConId fun = case occAnalArgs env args of + (arg_uds, args') -> (mapVarEnv markMany arg_uds, args') + -- We mark the free vars of the argument of a constructor as "many" + -- This means that nothing gets inlined into a constructor argument + -- position, which is what we want. Typically those constructor + -- arguments are just variables, or trivial expressions. + | otherwise = occAnalArgs env args + occAnalApp env (fun, args) = case occAnal (zapCtxt env) fun of { (fun_uds, fun') -> case occAnalArgs env args of { (args_uds, args') -> @@ -863,7 +844,7 @@ setBinderOcc usage bndr = -- Don't use local usage info for visible-elsewhere things -- BUT *do* erase any IAmALoopBreaker annotation, because we're -- about to re-generate it and it shouldn't be "sticky" - case getIdOccInfo bndr of + case idOccInfo bndr of NoOccInfo -> bndr other -> setIdOccInfo bndr NoOccInfo @@ -879,7 +860,7 @@ markBinderInsideLambda bndr = bndr | otherwise - = case getIdOccInfo bndr of + = case idOccInfo bndr of OneOcc _ once -> bndr `setIdOccInfo` OneOcc insideLam once other -> bndr diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs index cf67ced4d7..ed76213bf5 100644 --- a/ghc/compiler/simplCore/SAT.lhs +++ b/ghc/compiler/simplCore/SAT.lhs @@ -98,10 +98,6 @@ satExpr var@(Var v) satExpr lit@(Lit _) = returnSAT lit -satExpr e@(Con con types args) - = mapSAT satAtom args `thenSAT_` - returnSAT e - satExpr e@(Prim prim ty args) = mapSAT satAtom args `thenSAT_` returnSAT e diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 2ff47547db..ca226344cf 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -42,27 +42,25 @@ module SetLevels ( import CoreSyn -import CoreUtils ( coreExprType, exprIsTrivial, exprIsBottom ) +import CoreUtils ( exprType, exprIsTrivial, exprIsBottom ) import CoreFVs -- all of it -import Id ( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo, - getIdSpecialisation, getIdWorkerInfo +import Id ( Id, idType, idFreeTyVars, mkSysLocal, isOneShotLambda, modifyIdInfo, + idSpecialisation, idWorkerInfo, setIdInfo ) -import IdInfo ( workerExists ) -import Var ( IdOrTyVar, Var, TyVar, setVarUnique ) +import IdInfo ( workerExists, vanillaIdInfo ) +import Var ( Var, TyVar, setVarUnique ) import VarEnv import Subst import VarSet import Name ( getOccName ) import OccName ( occNameUserString ) -import Type ( isUnLiftedType, mkTyVarTy, mkForAllTys, Type ) +import Type ( isUnLiftedType, mkPiType, Type ) import BasicTypes ( TopLevelFlag(..) ) import VarSet import VarEnv import UniqSupply -import Maybes ( maybeToBool ) -import Util ( zipWithEqual, zipEqual ) +import Util ( sortLt, isSingleton, count ) import Outputable -import List ( nub ) \end{code} %************************************************************************ @@ -141,11 +139,12 @@ instance Outputable Level where %************************************************************************ \begin{code} -setLevels :: [CoreBind] +setLevels :: Bool -- True <=> float lambdas to top level + -> [CoreBind] -> UniqSupply -> [LevelledBind] -setLevels binds us +setLevels float_lams binds us = initLvl us (do_them binds) where -- "do_them"'s main business is to thread the monad along @@ -155,16 +154,18 @@ setLevels binds us do_them [] = returnLvl [] do_them (b:bs) - = lvlTopBind b `thenLvl` \ (lvld_bind, _) -> - do_them bs `thenLvl` \ lvld_binds -> + = lvlTopBind init_env b `thenLvl` \ (lvld_bind, _) -> + do_them bs `thenLvl` \ lvld_binds -> returnLvl (lvld_bind : lvld_binds) -lvlTopBind (NonRec binder rhs) - = lvlBind TopLevel tOP_LEVEL initialEnv (AnnNonRec binder (freeVars rhs)) + init_env = initialEnv float_lams + +lvlTopBind env (NonRec binder rhs) + = lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs)) -- Rhs can have no free vars! -lvlTopBind (Rec pairs) - = lvlBind TopLevel tOP_LEVEL initialEnv (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs]) +lvlTopBind env (Rec pairs) + = lvlBind TopLevel tOP_LEVEL env (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs]) \end{code} %************************************************************************ @@ -196,12 +197,9 @@ don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE If there were another lambda in @r@'s rhs, it would get level-2 as well. \begin{code} -lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty) -lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v) - -lvlExpr ctxt_lvl env (_, AnnCon con args) - = mapLvl (lvlExpr ctxt_lvl env) args `thenLvl` \ args' -> - returnLvl (Con con args') +lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty) +lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v) +lvlExpr _ env (_, AnnLit lit) = returnLvl (Lit lit) lvlExpr ctxt_lvl env (_, AnnApp fun arg) = lvlExpr ctxt_lvl env fun `thenLvl` \ fun' -> @@ -225,33 +223,12 @@ lvlExpr ctxt_lvl env (_, AnnNote note expr) -- lambdas makes them more expensive. lvlExpr ctxt_lvl env expr@(_, AnnLam bndr rhs) - = go (incMinorLvl ctxt_lvl) env False {- Havn't bumped major level in this group -} expr + = lvlMFE True new_lvl new_env body `thenLvl` \ new_body -> + returnLvl (glue_binders new_bndrs expr new_body) where - go lvl env bumped_major (_, AnnLam bndr body) - = go new_lvl new_env new_bumped_major body `thenLvl` \ new_body -> - returnLvl (Lam lvld_bndr new_body) - where - -- Go to the next major level if this is a value binder, - -- and we havn't already gone to the next level (one jump per group) - -- and it isn't a one-shot lambda - (new_lvl, new_bumped_major) - | isId bndr && - not bumped_major && - not (isOneShotLambda bndr) = (incMajorLvl ctxt_lvl, True) - | otherwise = (lvl, bumped_major) - new_env = extendLvlEnv env [lvld_bndr] - lvld_bndr = (bndr, new_lvl) - - -- Ignore notes, because we don't want to split - -- a lambda like this (\x -> coerce t (\s -> ...)) - -- This happens quite a bit in state-transformer programs - go lvl env bumped_major (_, AnnNote note body) - = go lvl env bumped_major body `thenLvl` \ new_body -> - returnLvl (Note note new_body) - - go lvl env bumped_major body - = lvlMFE True lvl env body - + (bndrs, body) = collect_binders expr + (new_lvl, new_bndrs) = lvlLamBndrs ctxt_lvl bndrs + new_env = extendLvlEnv env new_bndrs lvlExpr ctxt_lvl env (_, AnnLet bind body) = lvlBind NotTopLevel ctxt_lvl env bind `thenLvl` \ (bind', new_env) -> @@ -266,7 +243,7 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts) mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' -> returnLvl (Case expr' (case_bndr, incd_lvl) alts') where - expr_type = coreExprType (deAnnotate expr) + expr_type = exprType (deAnnotate expr) incd_lvl = incMinorLvl ctxt_lvl lvl_alt alts_env (con, bs, rhs) @@ -275,6 +252,21 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts) where bs' = [ (b, incd_lvl) | b <- bs ] new_env = extendLvlEnv alts_env bs' + +collect_binders lam + = go [] lam + where + go rev_bndrs (_, AnnLam b e) = go (b:rev_bndrs) e + go rev_bndrs (_, AnnNote n e) = go rev_bndrs e + go rev_bndrs rhs = (reverse rev_bndrs, rhs) + -- Ignore notes, because we don't want to split + -- a lambda like this (\x -> coerce t (\s -> ...)) + -- This happens quite a bit in state-transformer programs + + -- glue_binders puts the lambda back together +glue_binders (b:bs) (_, AnnLam _ e) body = Lam b (glue_binders bs e body) +glue_binders bs (_, AnnNote n e) body = Note n (glue_binders bs e body) +glue_binders [] e body = body \end{code} @lvlMFE@ is just like @lvlExpr@, except that it might let-bind @@ -308,16 +300,15 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) lvlExpr ctxt_lvl env ann_expr | otherwise -- Float it out! - = lvlExpr expr_lvl expr_env ann_expr `thenLvl` \ expr' -> - newLvlVar "lvl" (mkForAllTys tyvars ty) `thenLvl` \ var -> - returnLvl (Let (NonRec (var,dest_lvl) (mkLams tyvars_w_lvls expr')) - (mkTyVarApps var tyvars)) + = lvlFloatRhs abs_vars dest_lvl env ann_expr `thenLvl` \ expr' -> + newLvlVar "lvl" abs_vars ty `thenLvl` \ var -> + returnLvl (Let (NonRec (var,dest_lvl) expr') + (mkVarApps (Var var) abs_vars)) where expr = deAnnotate ann_expr - ty = coreExprType expr - dest_lvl = destLevel env fvs - (tyvars, tyvars_w_lvls, expr_lvl) = abstractTyVars dest_lvl env fvs - expr_env = extendLvlEnv env tyvars_w_lvls + ty = exprType expr + dest_lvl = destLevel env fvs (isFunction ann_expr) + abs_vars = abstractVars dest_lvl env fvs \end{code} @@ -338,53 +329,70 @@ lvlBind :: TopLevelFlag -- Used solely to decide whether to clone -> LvlM (LevelledBind, LevelEnv) lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) - | null tyvars + | null abs_vars = -- No type abstraction; clone existing binder - lvlExpr rhs_lvl rhs_env rhs `thenLvl` \ rhs' -> + lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' -> cloneVar top_lvl env bndr dest_lvl `thenLvl` \ (env', bndr') -> returnLvl (NonRec (bndr', dest_lvl) rhs', env') | otherwise = -- Yes, type abstraction; create a new binder, extend substitution, etc - WARN( workerExists (getIdWorkerInfo bndr) - || not (isEmptyCoreRules (getIdSpecialisation bndr)), - text "lvlBind: discarding info on" <+> ppr bndr ) - - lvl_poly_rhs tyvars_w_lvls rhs_lvl rhs_env rhs `thenLvl` \ rhs' -> - new_poly_bndr tyvars bndr `thenLvl` \ bndr' -> - let - env' = extendPolyLvlEnv env dest_lvl tyvars [(bndr, bndr')] - in + lvlFloatRhs abs_vars dest_lvl env rhs `thenLvl` \ rhs' -> + newPolyBndrs dest_lvl env abs_vars [bndr] `thenLvl` \ (env', [bndr']) -> returnLvl (NonRec (bndr', dest_lvl) rhs', env') where bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr + abs_vars = abstractVars dest_lvl env bind_fvs - dest_lvl | isUnLiftedType (idType bndr) = destLevel env bind_fvs `maxLvl` Level 1 0 - | otherwise = destLevel env bind_fvs + dest_lvl | isUnLiftedType (idType bndr) = destLevel env bind_fvs False `maxLvl` Level 1 0 + | otherwise = destLevel env bind_fvs (isFunction rhs) -- Hack alert! We do have some unlifted bindings, for cheap primops, and -- it is ok to float them out; but not to the top level. If they would otherwise -- go to the top level, we pin them inside the topmost lambda - - (tyvars, tyvars_w_lvls, rhs_lvl) = abstractTyVars dest_lvl env bind_fvs - rhs_env = extendLvlEnv env tyvars_w_lvls \end{code} \begin{code} lvlBind top_lvl ctxt_lvl env (AnnRec pairs) - | null tyvars + | null abs_vars = cloneVars top_lvl env bndrs dest_lvl `thenLvl` \ (new_env, new_bndrs) -> - mapLvl (lvlExpr rhs_lvl new_env) rhss `thenLvl` \ new_rhss -> + mapLvl (lvlExpr ctxt_lvl new_env) rhss `thenLvl` \ new_rhss -> returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env) - | otherwise - = mapLvl (new_poly_bndr tyvars) bndrs `thenLvl` \ new_bndrs -> + | isSingleton pairs && count isId abs_vars > 1 + = -- Special case for self recursion where there are + -- several variables carried around: build a local loop: + -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars + -- This just makes the closures a bit smaller. If we don't do + -- this, allocation rises significantly on some programs + -- + -- We could elaborate it for the case where there are several + -- mutually functions, but it's quite a bit more complicated + -- + -- This all seems a bit ad hoc -- sigh let - new_env = extendPolyLvlEnv env dest_lvl tyvars (bndrs `zip` new_bndrs) - rhs_env = extendLvlEnv new_env tyvars_w_lvls - in - mapLvl (lvl_poly_rhs tyvars_w_lvls rhs_lvl rhs_env) rhss `thenLvl` \ new_rhss -> + (bndr,rhs) = head pairs + (rhs_lvl, abs_vars_w_lvls) = lvlLamBndrs dest_lvl abs_vars + rhs_env = extendLvlEnv env abs_vars_w_lvls + in + cloneVar NotTopLevel rhs_env bndr rhs_lvl `thenLvl` \ (rhs_env', new_bndr) -> + let + (lam_bndrs, rhs_body) = collect_binders rhs + (body_lvl, new_lam_bndrs) = lvlLamBndrs rhs_lvl lam_bndrs + body_env = extendLvlEnv rhs_env' new_lam_bndrs + in + lvlExpr body_lvl body_env rhs_body `thenLvl` \ new_rhs_body -> + newPolyBndrs dest_lvl env abs_vars [bndr] `thenLvl` \ (poly_env, [poly_bndr]) -> + returnLvl (Rec [((poly_bndr,dest_lvl), mkLams abs_vars_w_lvls $ + glue_binders new_lam_bndrs rhs $ + Let (Rec [((new_bndr,rhs_lvl), mkLams new_lam_bndrs new_rhs_body)]) + (mkVarApps (Var new_bndr) lam_bndrs))], + poly_env) + + | otherwise + = newPolyBndrs dest_lvl env abs_vars bndrs `thenLvl` \ (new_env, new_bndrs) -> + mapLvl (lvlFloatRhs abs_vars dest_lvl new_env) rhss `thenLvl` \ new_rhss -> returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env) where @@ -396,20 +404,18 @@ lvlBind top_lvl ctxt_lvl env (AnnRec pairs) `minusVarSet` mkVarSet bndrs - dest_lvl = destLevel env bind_fvs - - (tyvars, tyvars_w_lvls, rhs_lvl) = abstractTyVars dest_lvl env bind_fvs + dest_lvl = destLevel env bind_fvs (all isFunction rhss) + abs_vars = abstractVars dest_lvl env bind_fvs ---------------------------------------------------- --- Three help functons Stuff for the type-abstraction case +-- Three help functons for the type-abstraction case -new_poly_bndr tyvars bndr - = newLvlVar ("poly_" ++ occNameUserString (getOccName bndr)) - (mkForAllTys tyvars (idType bndr)) - -lvl_poly_rhs tyvars_w_lvls rhs_lvl rhs_env rhs - = lvlExpr rhs_lvl rhs_env rhs `thenLvl` \ rhs' -> - returnLvl (mkLams tyvars_w_lvls rhs') +lvlFloatRhs abs_vars dest_lvl env rhs + = lvlExpr rhs_lvl rhs_env rhs `thenLvl` \ rhs' -> + returnLvl (mkLams abs_vars_w_lvls rhs') + where + (rhs_lvl, abs_vars_w_lvls) = lvlLamBndrs dest_lvl abs_vars + rhs_env = extendLvlEnv env abs_vars_w_lvls \end{code} @@ -420,45 +426,82 @@ lvl_poly_rhs tyvars_w_lvls rhs_lvl rhs_env rhs %************************************************************************ \begin{code} -abstractTyVars :: Level -> LevelEnv -> VarSet - -> ([TyVar], [(TyVar,Level)], Level) - -- Find the tyvars whose level is higher than the supplied level - -- There should be no Ids with this property -abstractTyVars lvl env fvs - | null tyvars = ([], [], lvl) -- Don't increment level - - | otherwise - = ASSERT( not (any bad fv_list) ) - (tyvars, tyvars_w_lvls, incd_lvl) +lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [(CoreBndr, Level)]) +-- Compute the levels for the binders of a lambda group +lvlLamBndrs lvl [] + = (lvl, []) + +lvlLamBndrs lvl bndrs + = go (incMinorLvl lvl) + False -- Havn't bumped major level in this group + [] bndrs where - bad v = isId v && lvl `ltLvl` varLevel env v - fv_list = varSetElems fvs - tyvars = nub [tv | v <- fv_list, tv <- tvs_of v, abstract_tv tv] + go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs) + | isId bndr && -- Go to the next major level if this is a value binder, + not bumped_major && -- and we havn't already gone to the next level (one jump per group) + not (isOneShotLambda bndr) -- and it isn't a one-shot lambda + = go new_lvl True ((bndr,new_lvl) : rev_lvld_bndrs) bndrs - -- If f is free in the exression, and f maps to poly_f a b c in the - -- current substitution, then we must report a b c as candidate type - -- variables - tvs_of v | isId v = lookupTyVars env v - | otherwise = [v] + | otherwise + = go old_lvl bumped_major ((bndr,old_lvl) : rev_lvld_bndrs) bndrs - abstract_tv var | isId var = False - | otherwise = lvl `ltLvl` varLevel env var + where + new_lvl = incMajorLvl old_lvl - -- These defns are just like those in the TyLam case of lvlExpr - incd_lvl = incMinorLvl lvl - tyvars_w_lvls = [(tv,incd_lvl) | tv <- tyvars] + go old_lvl _ rev_lvld_bndrs [] + = (old_lvl, reverse rev_lvld_bndrs) + -- a lambda like this (\x -> coerce t (\s -> ...)) + -- This happens quite a bit in state-transformer programs +\end{code} +\begin{code} +abstractVars :: Level -> LevelEnv -> VarSet -> [Var] + -- Find the variables in fvs, free vars of the target expresion, + -- whose level is less than than the supplied level + -- These are the ones we are going to abstract out +abstractVars dest_lvl env fvs + = uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv]) + where + -- Sort the variables so we don't get + -- mixed-up tyvars and Ids; it's just messy + v1 `lt` v2 = case (isId v1, isId v2) of + (True, False) -> False + (False, True) -> True + other -> v1 < v2 -- Same family + uniq :: [Var] -> [Var] + -- Remove adjacent duplicates; the sort will have brought them together + uniq (v1:v2:vs) | v1 == v2 = uniq (v2:vs) + | otherwise = v1 : uniq (v2:vs) + uniq vs = vs -- Destintion level is the max Id level of the expression -- (We'll abstract the type variables, if any.) -destLevel :: LevelEnv -> VarSet -> Level -destLevel env fvs = foldVarSet (maxIdLvl env) tOP_LEVEL fvs - -maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level -maxIdLvl (lvl_env,_,_) var lvl | isTyVar var = lvl - | otherwise = case lookupVarEnv lvl_env var of - Just lvl' -> maxLvl lvl' lvl - Nothing -> lvl +destLevel :: LevelEnv -> VarSet -> Bool -> Level +destLevel env fvs is_function + | floatLams env + && is_function = tOP_LEVEL -- Send functions to top level; see + -- the comments with isFunction + | otherwise = maxIdLevel env fvs + +isFunction :: CoreExprWithFVs -> Bool +-- The idea here is that we want to float *functions* to +-- the top level. This saves no work, but +-- (a) it can make the host function body a lot smaller, +-- and hence inlinable. +-- (b) it can also save allocation when the function is recursive: +-- h = \x -> letrec f = \y -> ...f...y...x... +-- in f x +-- becomes +-- f = \x y -> ...(f x)...y...x... +-- h = \x -> f x x +-- No allocation for f now. +-- We may only want to do this if there are sufficiently few free +-- variables. We certainly only want to do it for values, and not for +-- constructors. So the simple thing is just to look for lambdas +isFunction (_, AnnLam b e) | isId b = True + | otherwise = isFunction e +isFunction (_, AnnNote n e) = isFunction e +isFunction other = False \end{code} @@ -469,7 +512,10 @@ maxIdLvl (lvl_env,_,_) var lvl | isTyVar var = lvl %************************************************************************ \begin{code} -type LevelEnv = (VarEnv Level, SubstEnv, IdEnv ([TyVar], LevelledExpr)) +type LevelEnv = (Bool, -- True <=> Float lambdas too + VarEnv Level, -- Domain is *post-cloned* TyVars and Ids + SubstEnv, -- Domain is pre-cloned Ids + IdEnv ([Var], LevelledExpr)) -- Domain is pre-cloned Ids -- We clone let-bound variables so that they are still -- distinct when floated out; hence the SubstEnv/IdEnv. -- We also use these envs when making a variable polymorphic @@ -487,50 +533,97 @@ type LevelEnv = (VarEnv Level, SubstEnv, IdEnv ([TyVar], LevelledExpr)) -- the type application repeatedly. -- -- The domain of the both envs is *pre-cloned* Ids, though + -- + -- The domain of the VarEnv Level is the *post-cloned* Ids + +initialEnv :: Bool -> LevelEnv +initialEnv float_lams = (float_lams, emptyVarEnv, emptySubstEnv, emptyVarEnv) -initialEnv :: LevelEnv -initialEnv = (emptyVarEnv, emptySubstEnv, emptyVarEnv) +floatLams :: LevelEnv -> Bool +floatLams (float_lams, _, _, _) = float_lams extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv -- Used when *not* cloning -extendLvlEnv (lvl_env, subst_env, id_env) prs - = (foldl add lvl_env prs, subst_env, id_env) +extendLvlEnv (float_lams, lvl_env, subst_env, id_env) prs + = (float_lams, foldl add lvl_env prs, subst_env, id_env) where add env (v,l) = extendVarEnv env v l -- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can -extendCaseBndrLvlEnv (lvl_env, subst_env, id_env) scrut case_bndr lvl +extendCaseBndrLvlEnv env scrut case_bndr lvl = case scrut of - Var v -> (new_lvl_env, extendSubstEnv subst_env case_bndr (DoneEx (Var v)), - extendVarEnv id_env case_bndr ([], scrut)) - other -> (new_lvl_env, subst_env, id_env) + Var v -> extendCloneLvlEnv lvl env [(case_bndr, v)] + other -> extendLvlEnv env [(case_bndr,lvl)] + +extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst_env, id_env) abs_vars bndr_pairs + = (float_lams, + foldl add_lvl lvl_env bndr_pairs, + foldl add_subst subst_env bndr_pairs, + foldl add_id id_env bndr_pairs) where - new_lvl_env = extendVarEnv lvl_env case_bndr lvl + add_lvl env (v,v') = extendVarEnv env v' dest_lvl + add_subst env (v,v') = extendSubstEnv env v (DoneEx (mkVarApps (Var v') abs_vars)) + add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) -extendPolyLvlEnv (lvl_env, subst_env, id_env) dest_lvl tyvars bndr_pairs - = (foldl add_lvl lvl_env bndr_pairs, +extendCloneLvlEnv lvl (float_lams, lvl_env, subst_env, id_env) bndr_pairs + = (float_lams, + foldl add_lvl lvl_env bndr_pairs, foldl add_subst subst_env bndr_pairs, foldl add_id id_env bndr_pairs) where - add_lvl env (v,_ ) = extendVarEnv env v dest_lvl - add_subst env (v,v') = extendSubstEnv env v (DoneEx (mkTyVarApps v' tyvars)) - add_id env (v,v') = extendVarEnv env v (tyvars, mkTyVarApps v' tyvars) + add_lvl env (v,v') = extendVarEnv env v' lvl + add_subst env (v,v') = extendSubstEnv env v (DoneEx (Var v')) + add_id env (v,v') = extendVarEnv env v ([v'], Var v') + + +maxIdLevel :: LevelEnv -> VarSet -> Level +maxIdLevel (_, lvl_env,_,id_env) var_set + = foldVarSet max_in tOP_LEVEL var_set + where + max_in in_var lvl = foldr max_out lvl (case lookupVarEnv id_env in_var of + Just (abs_vars, _) -> abs_vars + Nothing -> [in_var]) -varLevel :: LevelEnv -> IdOrTyVar -> Level -varLevel (lvl_env, _, _) v - = case lookupVarEnv lvl_env v of - Just level -> level - Nothing -> tOP_LEVEL + max_out out_var lvl + | isId out_var = case lookupVarEnv lvl_env out_var of + Just lvl' -> maxLvl lvl' lvl + Nothing -> lvl + | otherwise = lvl -- Ignore tyvars in *maxIdLevel* lookupVar :: LevelEnv -> Id -> LevelledExpr -lookupVar (_, _, id_env) v = case lookupVarEnv id_env v of - Just (_, expr) -> expr - other -> Var v - -lookupTyVars :: LevelEnv -> Id -> [TyVar] -lookupTyVars (_, _, id_env) v = case lookupVarEnv id_env v of - Just (tyvars, _) -> tyvars - Nothing -> [] +lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of + Just (_, expr) -> expr + other -> Var v + +absVarsOf :: Level -> LevelEnv -> Var -> [Var] + -- If f is free in the exression, and f maps to poly_f a b c in the + -- current substitution, then we must report a b c as candidate type + -- variables +absVarsOf dest_lvl (_, lvl_env, _, id_env) v + | isId v + = [final_av | av <- lookup_avs v, abstract_me av, final_av <- add_tyvars av] + + | otherwise + = if abstract_me v then [v] else [] + + where + abstract_me v = case lookupVarEnv lvl_env v of + Just lvl -> dest_lvl `ltLvl` lvl + Nothing -> False + + lookup_avs v = case lookupVarEnv id_env v of + Just (abs_vars, _) -> abs_vars + Nothing -> [v] + + -- We are going to lambda-abstract, so nuke any IdInfo, + -- and add the tyvars of the Id + add_tyvars v | isId v = zap v : varSetElems (idFreeTyVars v) + | otherwise = [v] + + zap v = WARN( workerExists (idWorkerInfo v) + || not (isEmptyCoreRules (idSpecialisation v)), + text "absVarsOf: discarding info on" <+> ppr v ) + setIdInfo v vanillaIdInfo \end{code} \begin{code} @@ -543,43 +636,56 @@ mapLvl = mapUs \end{code} \begin{code} -newLvlVar :: String -> Type -> LvlM Id -newLvlVar str ty = getUniqueUs `thenLvl` \ uniq -> - returnUs (mkSysLocal (_PK_ str) uniq ty) +newPolyBndrs dest_lvl env abs_vars bndrs + = getUniquesUs (length bndrs) `thenLvl` \ uniqs -> + let + new_bndrs = zipWith mk_poly_bndr bndrs uniqs + in + returnLvl (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs) + where + mk_poly_bndr bndr uniq = mkSysLocal (_PK_ str) uniq poly_ty + where + str = "poly_" ++ occNameUserString (getOccName bndr) + poly_ty = foldr mkPiType (idType bndr) abs_vars + +newLvlVar :: String + -> [CoreBndr] -> Type -- Abstract wrt these bndrs + -> LvlM Id +newLvlVar str vars body_ty + = getUniqueUs `thenLvl` \ uniq -> + returnUs (mkSysLocal (_PK_ str) uniq (foldr mkPiType body_ty vars)) + -- The deeply tiresome thing is that we have to apply the substitution -- to the rules inside each Id. Grr. But it matters. cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> LvlM (LevelEnv, Id) cloneVar TopLevel env v lvl = returnUs (env, v) -- Don't clone top level things -cloneVar NotTopLevel (lvl_env, subst_env, id_env) v lvl +cloneVar NotTopLevel env v lvl = getUniqueUs `thenLvl` \ uniq -> let - subst = mkSubst emptyVarSet subst_env v' = setVarUnique v uniq - v'' = modifyIdInfo (\info -> substIdInfo subst info info) v' - subst_env' = extendSubstEnv subst_env v (DoneEx (Var v'')) - id_env' = extendVarEnv id_env v ([], Var v'') - lvl_env' = extendVarEnv lvl_env v lvl + v'' = subst_id_info env v' + env' = extendCloneLvlEnv lvl env [(v,v'')] in - returnUs ((lvl_env', subst_env', id_env'), v'') + returnUs (env', v'') cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id]) cloneVars TopLevel env vs lvl = returnUs (env, vs) -- Don't clone top level things -cloneVars NotTopLevel (lvl_env, subst_env, id_env) vs lvl +cloneVars NotTopLevel env vs lvl = getUniquesUs (length vs) `thenLvl` \ uniqs -> let - subst = mkSubst emptyVarSet subst_env' vs' = zipWith setVarUnique vs uniqs - vs'' = map (modifyIdInfo (\info -> substIdInfo subst info info)) vs' - subst_env' = extendSubstEnvList subst_env vs [DoneEx (Var v'') | v'' <- vs''] - id_env' = extendVarEnvList id_env (vs `zip` [([], Var v') | v' <- vs'']) - lvl_env' = extendVarEnvList lvl_env (vs `zip` repeat lvl) + vs'' = map (subst_id_info env') vs' + env' = extendCloneLvlEnv lvl env (vs `zip` vs'') in - returnUs ((lvl_env', subst_env', id_env'), vs'') + returnUs (env', vs'') -mkTyVarApps var tyvars = foldl (\e tv -> App e (Type (mkTyVarTy tv))) - (Var var) tyvars +subst_id_info (_, _, subst_env, _) v + = modifyIdInfo (\info -> substIdInfo subst info info) v + where + subst = mkSubst emptyVarSet subst_env \end{code} + diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 13db4fac0f..5e11d8180b 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -25,15 +25,15 @@ import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, import CoreUnfold import PprCore ( pprCoreBindings ) import OccurAnal ( occurAnalyseBinds ) -import CoreUtils ( exprIsTrivial, coreExprType ) +import CoreUtils ( exprIsTrivial, etaReduceExpr ) import Simplify ( simplTopBinds, simplExpr ) -import SimplUtils ( etaCoreExpr, findDefault, simplBinders ) +import SimplUtils ( findDefault, simplBinders ) import SimplMonad -import Const ( Con(..), Literal(..), literalType, mkMachInt ) +import Literal ( Literal(..), literalType, mkMachInt ) import ErrUtils ( dumpIfSet ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId, +import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId, isDataConWrapId, idType, setIdType, idName, idInfo, setIdNoDiscard ) import VarEnv @@ -63,7 +63,6 @@ import Unique ( Unique, Uniquable(..), ratioTyConKey ) import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply ) -import Constants ( tARGET_MIN_INT, tARGET_MAX_INT ) import Util ( mapAccumL ) import SrcLoc ( noSrcLoc ) import Bag @@ -107,11 +106,8 @@ core2core core_todos binds rules "Grand total simplifier statistics" (pprSimplCount stats) - -- Do the post-simplification business - post_simpl_binds <- doPostSimplification ps_us processed_binds - -- Return results - return (post_simpl_binds, filter orphanRule better_rules) + return (processed_binds, filter orphanRule better_rules) doCorePasses stats us binds irs [] @@ -127,7 +123,7 @@ doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplify doCorePass us binds rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds) doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds) doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds) -doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds) +doCorePass us binds rb (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" noStats (floatOutwards f us binds) doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds) doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds) doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds) @@ -173,8 +169,11 @@ simplRules us rules binds return better_rules where - black_list_all v = True -- This stops all inlining - sw_chkr any = SwBool False -- A bit bogus + black_list_all v = not (isDataConWrapId v) + -- This stops all inlining except the + -- wrappers for data constructors + + sw_chkr any = SwBool False -- A bit bogus -- Boringly, we need to gather the in-scope set. -- Typically this thunk won't even be force, but the test in @@ -200,7 +199,7 @@ simpl_arg e -- Otherwise we don't match when given an argument like -- (\a. h a a) = simplExpr e `thenSmpl` \ e' -> - returnSmpl (etaCoreExpr e') + returnSmpl (etaReduceExpr e') \end{code} %************************************************************************ @@ -320,287 +319,3 @@ simplifyPgm (imported_rule_ids, rule_lhs_fvs) where (us1, us2) = splitUniqSupply us \end{code} - - -%************************************************************************ -%* * -\subsection{PostSimplification} -%* * -%************************************************************************ - -Several tasks are performed by the post-simplification pass - -1. Make the representation of NoRep literals explicit, and - float their bindings to the top level. We only do the floating - part for NoRep lits inside a lambda (else no gain). We need to - take care with let x = "foo" in e - that we don't end up with a silly binding - let x = y in e - with a floated "foo". What a bore. - -4. Do eta reduction for lambda abstractions appearing in: - - the RHS of case alternatives - - the body of a let - - These will otherwise turn into local bindings during Core->STG; - better to nuke them if possible. (In general the simplifier does - eta expansion not eta reduction, up to this point. It does eta - on the RHSs of bindings but not the RHSs of case alternatives and - let bodies) - - -------------------- NOT DONE ANY MORE ------------------------ -[March 98] Indirections are now elimianted by the occurrence analyser -1. Eliminate indirections. The point here is to transform - x_local = E - x_exported = x_local - ==> - x_exported = E - -[Dec 98] [Not now done because there is no penalty in the code - generator for using the former form] -2. Convert - case x of {...; x' -> ...x'...} - ==> - case x of {...; _ -> ...x... } - See notes in SimplCase.lhs, near simplDefault for the reasoning here. --------------------------------------------------------------- - -Special case -~~~~~~~~~~~~ - -NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish -things, and we need local Ids for non-floated stuff): - - Don't float stuff out of a binder that's marked as a bottoming Id. - Reason: it doesn't do any good, and creates more CAFs that increase - the size of SRTs. - -eg. - - f = error "string" - -is translated to - - f' = unpackCString# "string" - f = error f' - -hence f' and f become CAFs. Instead, the special case for -tidyTopBinding below makes sure this comes out as - - f = let f' = unpackCString# "string" in error f' - -and we can safely ignore f as a CAF, since it can only ever be entered once. - - - -\begin{code} -doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind] -doPostSimplification us binds_in - = do - beginPass "Post-simplification pass" - let binds_out = initPM us (postSimplTopBinds binds_in) - endPass "Post-simplification pass" opt_D_verbose_core2core binds_out - -postSimplTopBinds :: [CoreBind] -> PostM [CoreBind] -postSimplTopBinds binds - = mapPM postSimplTopBind binds `thenPM` \ binds' -> - returnPM (bagToList (unionManyBags binds')) - -postSimplTopBind :: CoreBind -> PostM (Bag CoreBind) -postSimplTopBind (NonRec bndr rhs) - | isBottomingId bndr -- Don't lift out floats for bottoming Ids - -- See notes above - = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) -> - returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats))) - -postSimplTopBind bind - = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) -> - returnPM (floats `snocBag` bind') - -postSimplBind (NonRec bndr rhs) - = postSimplExpr rhs `thenPM` \ rhs' -> - returnPM (NonRec bndr rhs') - -postSimplBind (Rec pairs) - = mapPM postSimplExpr rhss `thenPM` \ rhss' -> - returnPM (Rec (bndrs `zip` rhss')) - where - (bndrs, rhss) = unzip pairs -\end{code} - - -Expressions -~~~~~~~~~~~ -\begin{code} -postSimplExpr (Var v) = returnPM (Var v) -postSimplExpr (Type ty) = returnPM (Type ty) - -postSimplExpr (App fun arg) - = postSimplExpr fun `thenPM` \ fun' -> - postSimplExpr arg `thenPM` \ arg' -> - returnPM (App fun' arg') - -postSimplExpr (Con (Literal lit) args) - = ASSERT( null args ) - litToRep lit `thenPM` \ (lit_ty, lit_expr) -> - getInsideLambda `thenPM` \ in_lam -> - if in_lam && not (exprIsTrivial lit_expr) then - -- It must have been a no-rep literal with a - -- non-trivial representation; and we're inside a lambda; - -- so float it to the top - addTopFloat lit_ty lit_expr `thenPM` \ v -> - returnPM (Var v) - else - returnPM lit_expr - -postSimplExpr (Con con args) - = mapPM postSimplExpr args `thenPM` \ args' -> - returnPM (Con con args') - -postSimplExpr (Lam bndr body) - = insideLambda bndr $ - postSimplExpr body `thenPM` \ body' -> - returnPM (Lam bndr body') - -postSimplExpr (Let bind body) - = postSimplBind bind `thenPM` \ bind' -> - postSimplExprEta body `thenPM` \ body' -> - returnPM (Let bind' body') - -postSimplExpr (Note note body) - = postSimplExpr body `thenPM` \ body' -> - -- Do *not* call postSimplExprEta here - -- We don't want to turn f = \x -> coerce t (\y -> f x y) - -- into f = \x -> coerce t (f x) - -- because then f has a lower arity. - -- This is not only bad in general, it causes the arity to - -- not match the [Demand] on an Id, - -- which confuses the importer of this module. - returnPM (Note note body') - -postSimplExpr (Case scrut case_bndr alts) - = postSimplExpr scrut `thenPM` \ scrut' -> - mapPM ps_alt alts `thenPM` \ alts' -> - returnPM (Case scrut' case_bndr alts') - where - ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' -> - returnPM (con, bndrs, rhs') - -postSimplExprEta e = postSimplExpr e `thenPM` \ e' -> - returnPM (etaCoreExpr e') -\end{code} - - -%************************************************************************ -%* * -\subsection[coreToStg-lits]{Converting literals} -%* * -%************************************************************************ - -Literals: the NoRep kind need to be de-no-rep'd. -We always replace them with a simple variable, and float a suitable -binding out to the top level. - -\begin{code} -litToRep :: Literal -> PostM (Type, CoreExpr) - -litToRep (NoRepStr s ty) - = returnPM (ty, rhs) - where - rhs = if (any is_NUL (_UNPK_ s)) - - then -- Must cater for NULs in literal string - mkApps (Var unpackCString2Id) - [mkLit (MachStr s), - mkLit (mkMachInt (toInteger (_LENGTH_ s)))] - - else -- No NULs in the string - App (Var unpackCStringId) (mkLit (MachStr s)) - - is_NUL c = c == '\0' -\end{code} - -If an Integer is small enough (Haskell implementations must support -Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@; -otherwise, wrap with @addr2Integer@. - -\begin{code} -litToRep (NoRepInteger i integer_ty) - = returnPM (integer_ty, rhs) - where - rhs | i >= tARGET_MIN_INT && -- Small enough, so start from an Int - i <= tARGET_MAX_INT - = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []] - - | otherwise -- Big, so start from a string - = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) []) - - -litToRep (NoRepRational r rational_ty) - = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg -> - postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg -> - returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg]) - where - (ratio_data_con, integer_ty) - = case (splitAlgTyConApp_maybe rational_ty) of - Just (tycon, [i_ty], [con]) - -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey) - (con, i_ty) - - _ -> (panic "ratio_data_con", panic "integer_ty") - -litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit) -\end{code} - - -%************************************************************************ -%* * -\subsection{The monad} -%* * -%************************************************************************ - -\begin{code} -type PostM a = Bool -- True <=> inside a *value* lambda - -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in - -> (a, (UniqSupply, Bag CoreBind)) - -initPM :: UniqSupply -> PostM a -> a -initPM us m - = case m False {- not inside lambda -} (us, emptyBag) of - (result, _) -> result - -returnPM v in_lam usf = (v, usf) -thenPM m k in_lam usf = case m in_lam usf of - (r, usf') -> k r in_lam usf' - -mapPM f [] = returnPM [] -mapPM f (x:xs) = f x `thenPM` \ r -> - mapPM f xs `thenPM` \ rs -> - returnPM (r:rs) - -insideLambda :: CoreBndr -> PostM a -> PostM a -insideLambda bndr m in_lam usf | isId bndr = m True usf - | otherwise = m in_lam usf - -getInsideLambda :: PostM Bool -getInsideLambda in_lam usf = (in_lam, usf) - -getFloatsPM :: PostM a -> PostM (a, Bag CoreBind) -getFloatsPM m in_lam (us, floats) - = let - (a, (us', floats')) = m in_lam (us, emptyBag) - in - ((a, floats'), (us', floats)) - -addTopFloat :: Type -> CoreExpr -> PostM Id -addTopFloat lit_ty lit_rhs in_lam (us, floats) - = let - (us1, us2) = splitUniqSupply us - uniq = uniqFromSupply us1 - lit_id = mkSysLocal SLIT("lf") uniq lit_ty - in - (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs)) -\end{code} - - diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index af977c51a7..903c0fec4d 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -9,11 +9,6 @@ module SimplMonad ( OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, OutExprStuff, OutStuff, - -- The continuation type - SimplCont(..), DupFlag(..), contIsDupable, contResultType, - contIsInteresting, pushArgs, discardCont, countValArgs, countArgs, - contArgs, contIsInline, discardInline, - -- The monad SimplM, initSmpl, returnSmpl, thenSmpl, thenSmpl_, @@ -50,12 +45,11 @@ module SimplMonad ( #include "HsVersions.h" -import Const ( Con(DEFAULT) ) -import Id ( Id, mkSysLocal, getIdUnfolding ) +import Id ( Id, mkSysLocal, idUnfolding, isDataConWrapId ) import IdInfo ( InlinePragInfo(..) ) import Demand ( Demand ) import CoreSyn -import CoreUnfold ( isCompulsoryUnfolding ) +import CoreUnfold ( isCompulsoryUnfolding, isEvaldUnfolding ) import PprCore () -- Instances import Rules ( RuleBase ) import CostCentre ( CostCentreStack, subsumedCCS ) @@ -64,9 +58,9 @@ import Var ( TyVar ) import VarEnv import VarSet import qualified Subst -import Subst ( Subst, emptySubst, mkSubst, - substTy, substEnv, substExpr, - InScopeSet, substInScope, isInScope, lookupInScope +import Subst ( Subst, emptySubst, mkSubst, + substTy, substEnv, + InScopeSet, substInScope, isInScope ) import Type ( Type, TyVarSubst, applyTy ) import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply, @@ -82,7 +76,7 @@ import Maybes ( expectJust ) import Util ( zipWithEqual ) import Outputable -infixr 9 `thenSmpl`, `thenSmpl_` +infixr 0 `thenSmpl`, `thenSmpl_` \end{code} %************************************************************************ @@ -109,184 +103,12 @@ type OutAlt = CoreAlt type OutArg = CoreArg type SwitchChecker = SimplifierSwitch -> SwitchResult -\end{code} - -%************************************************************************ -%* * -\subsection{The continuation data type} -%* * -%************************************************************************ - -\begin{code} type OutExprStuff = OutStuff (InScopeSet, OutExpr) type OutStuff a = ([OutBind], a) -- We return something equivalent to (let b in e), but -- in pieces to avoid the quadratic blowup when floating -- incrementally. Comments just before simplExprB in Simplify.lhs - -data SimplCont -- Strict contexts - = Stop OutType -- Type of the result - - | CoerceIt OutType -- The To-type, simplified - SimplCont - - | InlinePlease -- This continuation makes a function very - SimplCont -- keen to inline itelf - - | ApplyTo DupFlag - InExpr SubstEnv -- The argument, as yet unsimplified, - SimplCont -- and its subst-env - - | Select DupFlag - InId [InAlt] SubstEnv -- The case binder, alts, and subst-env - SimplCont - - | ArgOf DupFlag -- An arbitrary strict context: the argument - -- of a strict function, or a primitive-arg fn - -- or a PrimOp - OutType -- The type of the expression being sought by the context - -- f (error "foo") ==> coerce t (error "foo") - -- when f is strict - -- We need to know the type t, to which to coerce. - (OutExpr -> SimplM OutExprStuff) -- What to do with the result - -instance Outputable SimplCont where - ppr (Stop _) = ptext SLIT("Stop") - ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont - ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup - ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ - (nest 4 (ppr alts)) $$ ppr cont - ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont - ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont - -data DupFlag = OkToDup | NoDup - -instance Outputable DupFlag where - ppr OkToDup = ptext SLIT("ok") - ppr NoDup = ptext SLIT("nodup") - -contIsDupable :: SimplCont -> Bool -contIsDupable (Stop _) = True -contIsDupable (ApplyTo OkToDup _ _ _) = True -contIsDupable (ArgOf OkToDup _ _) = True -contIsDupable (Select OkToDup _ _ _ _) = True -contIsDupable (CoerceIt _ cont) = contIsDupable cont -contIsDupable (InlinePlease cont) = contIsDupable cont -contIsDupable other = False - -contArgs :: InScopeSet -> SimplCont -> ([OutExpr], SimplCont) - -- Get the arguments from the continuation - -- Apply the appropriate substitution first; - -- this is done lazily and typically only the bit at the top is used -contArgs in_scope (ApplyTo _ e s cont) - = case contArgs in_scope cont of - (args, result) -> (substExpr (mkSubst in_scope s) e : args, result) -contArgs in_scope result_cont - = ([], result_cont) - -contIsInline :: SimplCont -> Bool -contIsInline (InlinePlease cont) = True -contIsInline other = False - -discardInline :: SimplCont -> SimplCont -discardInline (InlinePlease cont) = cont -discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont) -discardInline cont = cont -\end{code} - - -Comment about contIsInteresting -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to avoid inlining an expression where there can't possibly be -any gain, such as in an argument position. Hence, if the continuation -is interesting (eg. a case scrutinee, application etc.) then we -inline, otherwise we don't. - -Previously some_benefit used to return True only if the variable was -applied to some value arguments. This didn't work: - - let x = _coerce_ (T Int) Int (I# 3) in - case _coerce_ Int (T Int) x of - I# y -> .... - -we want to inline x, but can't see that it's a constructor in a case -scrutinee position, and some_benefit is False. - -Another example: - -dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) - -.... case dMonadST _@_ x0 of (a,b,c) -> .... - -we'd really like to inline dMonadST here, but we *don't* want to -inline if the case expression is just - - case x of y { DEFAULT -> ... } - -since we can just eliminate this case instead (x is in WHNF). Similar -applies when x is bound to a lambda expression. Hence -contIsInteresting looks for case expressions with just a single -default case. - -\begin{code} -contIsInteresting :: SimplCont -> Bool -contIsInteresting (Select _ _ alts _ _) = not (just_default alts) -contIsInteresting (CoerceIt _ cont) = contIsInteresting cont -contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont -contIsInteresting (ApplyTo _ _ _ _) = True - -contIsInteresting (ArgOf _ _ _) = False - -- If this call is the arg of a strict function, the context - -- is a bit interesting. If we inline here, we may get useful - -- evaluation information to avoid repeated evals: e.g. - -- x + (y * z) - -- Here the contIsInteresting makes the '*' keener to inline, - -- which in turn exposes a constructor which makes the '+' inline. - -- Assuming that +,* aren't small enough to inline regardless. - -- - -- HOWEVER, I put this back to False when I discovered that strings - -- were getting inlined straight back into applications of 'error' - -- because the latter is strict. - -- s = "foo" - -- f = \x -> ...(error s)... - -contIsInteresting (InlinePlease _) = True -contIsInteresting other = False - -just_default [(DEFAULT,_,_)] = True -- See notes below for why we look -just_default alts = False -- for this special case -\end{code} - - -\begin{code} -pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont -pushArgs se [] cont = cont -pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont) - -discardCont :: SimplCont -- A continuation, expecting - -> SimplCont -- Replace the continuation with a suitable coerce -discardCont (Stop to_ty) = Stop to_ty -discardCont cont = CoerceIt to_ty (Stop to_ty) - where - to_ty = contResultType cont - -contResultType :: SimplCont -> OutType -contResultType (Stop to_ty) = to_ty -contResultType (ArgOf _ to_ty _) = to_ty -contResultType (ApplyTo _ _ _ cont) = contResultType cont -contResultType (CoerceIt _ cont) = contResultType cont -contResultType (InlinePlease cont) = contResultType cont -contResultType (Select _ _ _ _ cont) = contResultType cont - -countValArgs :: SimplCont -> Int -countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont -countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont -countValArgs other = 0 - -countArgs :: SimplCont -> Int -countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont -countArgs other = 0 \end{code} @@ -745,27 +567,16 @@ environment seems like wild overkill. \begin{code} switchOffInlining :: SimplM a -> SimplM a switchOffInlining m env us sc - = m (env { seBlackList = \v -> not (isCompulsoryUnfolding (getIdUnfolding v)) && + = m (env { seBlackList = \v -> not (isCompulsoryUnfolding (idUnfolding v)) && + not (isDataConWrapId v) && ((v `isInScope` subst) || not (isLocallyDefined v)) }) us sc - -- Black list anything that is in scope or imported. - -- The in-scope thing arranges *not* to black list inlinings that are - -- completely inside the switch-off-inlining block. - -- This allows simplification to proceed un-hindered inside the block. - -- - -- At one time I had an exception for constant Ids (constructors, primops) - -- && (old_black_list v || not (isConstantId v )) - -- because (a) some don't have bindings, so we never want not to inline them - -- (b) their defns are very seldom big, so there's no size penalty - -- to inline them - -- But that failed because if we inline (say) [] in build's rhs, then - -- the exported thing doesn't match rules - -- - -- But we must inline primops (which have compulsory unfoldings) in the - -- last phase of simplification, because they don't have bindings. - -- The simplifier now *never* inlines blacklisted things (even if they - -- have compulsory unfoldings) so we must not black-list compulsory - -- unfoldings inside INLINE prags. + + -- Inside inlinings, black list anything that is in scope or imported. + -- except for things that must be unfolded (Compulsory) + -- and data con wrappers. The latter is a hack, like the one in + -- SimplCore.simplRules, to make wrappers inline in rule LHSs. We + -- may as well do the same here. where subst = seSubst env old_black_list = seBlackList env diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 835047bf11..4999db59ea 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -7,9 +7,13 @@ module SimplUtils ( simplBinder, simplBinders, simplIds, transformRhs, - etaCoreExpr, mkCase, findAlt, findDefault, - mkCoerce + + -- The continuation type + SimplCont(..), DupFlag(..), contIsDupable, contResultType, + pushArgs, discardCont, countValArgs, countArgs, + analyseCont, discardInline + ) where #include "HsVersions.h" @@ -17,16 +21,16 @@ module SimplUtils ( import BinderInfo import CmdLineOpts ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge ) import CoreSyn +import CoreUnfold ( isValueUnfolding ) import CoreFVs ( exprFreeVars ) -import CoreUtils ( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap, exprEtaExpandArity ) -import Subst ( substBndrs, substBndr, substIds ) -import Id ( Id, idType, getIdArity, isId, idName, - getIdOccInfo, - getIdDemandInfo, mkId, idInfo +import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity ) +import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst ) +import Id ( Id, idType, isId, idName, + idOccInfo, idUnfolding, + idDemandInfo, mkId, idInfo ) import IdInfo ( arityLowerBound, setOccInfo, vanillaIdInfo ) import Maybes ( maybeToBool, catMaybes ) -import Const ( Con(..) ) import Name ( isLocalName, setNameUnique ) import SimplMonad import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, @@ -35,6 +39,7 @@ import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, import TysPrim ( statePrimTyCon ) import Var ( setVarUnique ) import VarSet +import VarEnv ( SubstEnv, SubstResult(..) ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import Util ( zipWithEqual, mapAccumL ) import Outputable @@ -43,6 +48,238 @@ import Outputable %************************************************************************ %* * +\subsection{The continuation data type} +%* * +%************************************************************************ + +\begin{code} +data SimplCont -- Strict contexts + = Stop OutType -- Type of the result + + | CoerceIt OutType -- The To-type, simplified + SimplCont + + | InlinePlease -- This continuation makes a function very + SimplCont -- keen to inline itelf + + | ApplyTo DupFlag + InExpr SubstEnv -- The argument, as yet unsimplified, + SimplCont -- and its subst-env + + | Select DupFlag + InId [InAlt] SubstEnv -- The case binder, alts, and subst-env + SimplCont + + | ArgOf DupFlag -- An arbitrary strict context: the argument + -- of a strict function, or a primitive-arg fn + -- or a PrimOp + OutType -- The type of the expression being sought by the context + -- f (error "foo") ==> coerce t (error "foo") + -- when f is strict + -- We need to know the type t, to which to coerce. + (OutExpr -> SimplM OutExprStuff) -- What to do with the result + +instance Outputable SimplCont where + ppr (Stop _) = ptext SLIT("Stop") + ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont + ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup + ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ + (nest 4 (ppr alts)) $$ ppr cont + ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont + ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont + +data DupFlag = OkToDup | NoDup + +instance Outputable DupFlag where + ppr OkToDup = ptext SLIT("ok") + ppr NoDup = ptext SLIT("nodup") + +contIsDupable :: SimplCont -> Bool +contIsDupable (Stop _) = True +contIsDupable (ApplyTo OkToDup _ _ _) = True +contIsDupable (ArgOf OkToDup _ _) = True +contIsDupable (Select OkToDup _ _ _ _) = True +contIsDupable (CoerceIt _ cont) = contIsDupable cont +contIsDupable (InlinePlease cont) = contIsDupable cont +contIsDupable other = False + +pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont +pushArgs se [] cont = cont +pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont) + +discardCont :: SimplCont -- A continuation, expecting + -> SimplCont -- Replace the continuation with a suitable coerce +discardCont (Stop to_ty) = Stop to_ty +discardCont cont = CoerceIt to_ty (Stop to_ty) + where + to_ty = contResultType cont + +contResultType :: SimplCont -> OutType +contResultType (Stop to_ty) = to_ty +contResultType (ArgOf _ to_ty _) = to_ty +contResultType (ApplyTo _ _ _ cont) = contResultType cont +contResultType (CoerceIt _ cont) = contResultType cont +contResultType (InlinePlease cont) = contResultType cont +contResultType (Select _ _ _ _ cont) = contResultType cont + +countValArgs :: SimplCont -> Int +countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont +countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont +countValArgs other = 0 + +countArgs :: SimplCont -> Int +countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont +countArgs other = 0 +\end{code} + + +Comment about analyseCont +~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to avoid inlining an expression where there can't possibly be +any gain, such as in an argument position. Hence, if the continuation +is interesting (eg. a case scrutinee, application etc.) then we +inline, otherwise we don't. + +Previously some_benefit used to return True only if the variable was +applied to some value arguments. This didn't work: + + let x = _coerce_ (T Int) Int (I# 3) in + case _coerce_ Int (T Int) x of + I# y -> .... + +we want to inline x, but can't see that it's a constructor in a case +scrutinee position, and some_benefit is False. + +Another example: + +dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) + +.... case dMonadST _@_ x0 of (a,b,c) -> .... + +we'd really like to inline dMonadST here, but we *don't* want to +inline if the case expression is just + + case x of y { DEFAULT -> ... } + +since we can just eliminate this case instead (x is in WHNF). Similar +applies when x is bound to a lambda expression. Hence +contIsInteresting looks for case expressions with just a single +default case. + +\begin{code} +analyseCont :: InScopeSet -> SimplCont + -> ([Bool], -- Arg-info flags; one for each value argument + Bool, -- Context of the result of the call is interesting + Bool) -- There was an InlinePlease + +analyseCont in_scope cont + = case cont of + -- The "lone-variable" case is important. I spent ages + -- messing about with unsatisfactory varaints, but this is nice. + -- The idea is that if a variable appear all alone + -- as an arg of lazy fn, or rhs Stop + -- as scrutinee of a case Select + -- as arg of a strict fn ArgOf + -- then we should not inline it (unless there is some other reason, + -- e.g. is is the sole occurrence). + -- Why not? At least in the case-scrutinee situation, turning + -- case x of y -> ... + -- into + -- let y = (a,b) in ... + -- is bad if the binding for x will remain. + -- + -- Another example: I discovered that strings + -- were getting inlined straight back into applications of 'error' + -- because the latter is strict. + -- s = "foo" + -- f = \x -> ...(error s)... + + -- Fundamentally such contexts should not ecourage inlining becuase + -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE) + -- so there's no gain. + -- + -- However, even a type application isn't a lone variable. Consider + -- case $fMonadST @ RealWorld of { :DMonad a b c -> c } + -- We had better inline that sucker! The case won't see through it. + + (Stop _) -> boring_result -- Don't inline a lone variable + (Select _ _ _ _ _) -> boring_result -- Ditto + (ArgOf _ _ _) -> boring_result -- Ditto + (ApplyTo _ (Type _) _ cont) -> analyse_ty_app cont + other -> analyse_app cont + where + boring_result = ([], False, False) + + -- For now, I'm treating not treating a variable applied to types as + -- "lone". The motivating example was + -- f = /\a. \x. BIG + -- g = /\a. \y. h (f a) + -- There's no advantage in inlining f here, and perhaps + -- a significant disadvantage. + analyse_ty_app (Stop _) = boring_result + analyse_ty_app (ArgOf _ _ _) = boring_result + analyse_ty_app (Select _ _ _ _ _) = ([], True, False) -- See the $fMonadST example above + analyse_ty_app (ApplyTo _ (Type _) _ cont) = analyse_ty_app cont + analyse_ty_app cont = analyse_app cont + + analyse_app (InlinePlease cont) + = case analyse_app cont of + (infos, icont, inline) -> (infos, icont, True) + + analyse_app (ApplyTo _ arg subst cont) + | isValArg arg = case analyse_app cont of + (infos, icont, inline) -> (analyse_arg subst arg : infos, icont, inline) + | otherwise = analyse_app cont + + analyse_app cont = ([], interesting_call_context cont, False) + + -- An argument is interesting if it has *some* structure + -- We are here trying to avoid unfolding a function that + -- is applied only to variables that have no unfolding + -- (i.e. they are probably lambda bound): f x y z + -- There is little point in inlining f here. + analyse_arg :: SubstEnv -> InExpr -> Bool + analyse_arg subst (Var v) = case lookupIdSubst (mkSubst in_scope subst) v of + DoneId v' _ -> isValueUnfolding (idUnfolding v') + other -> False + analyse_arg subst (Type _) = False + analyse_arg subst (App fn (Type _)) = analyse_arg subst fn + analyse_arg subst (Note _ a) = analyse_arg subst a + analyse_arg subst other = True + + interesting_call_context (Stop _) = False + interesting_call_context (InlinePlease _) = True + interesting_call_context (Select _ _ _ _ _) = True + interesting_call_context (CoerceIt _ cont) = interesting_call_context cont + interesting_call_context (ApplyTo _ (Type _) _ cont) = interesting_call_context cont + interesting_call_context (ApplyTo _ _ _ _) = True + interesting_call_context (ArgOf _ _ _) = True + -- If this call is the arg of a strict function, the context + -- is a bit interesting. If we inline here, we may get useful + -- evaluation information to avoid repeated evals: e.g. + -- x + (y * z) + -- Here the contIsInteresting makes the '*' keener to inline, + -- which in turn exposes a constructor which makes the '+' inline. + -- Assuming that +,* aren't small enough to inline regardless. + -- + -- It's also very important to inline in a strict context for things + -- like + -- foldr k z (f x) + -- Here, the context of (f x) is strict, and if f's unfolding is + -- a build it's *great* to inline it here. So we must ensure that + -- the context for (f x) is not totally uninteresting. + + +discardInline :: SimplCont -> SimplCont +discardInline (InlinePlease cont) = cont +discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont) +discardInline cont = cont +\end{code} + + + +%************************************************************************ +%* * \section{Dealing with a single binder} %* * %************************************************************************ @@ -254,7 +491,7 @@ mkRhsTyLam tyvars body -- Only does something if there's a let -- where x* has an INLINE prag on it. Now, once x* is inlined, -- the occurrences of x' will be just the occurrences originaly -- pinned on x. - poly_info = vanillaIdInfo `setOccInfo` getIdOccInfo var + poly_info = vanillaIdInfo `setOccInfo` idOccInfo var poly_id = mkId poly_name poly_ty poly_info in @@ -326,16 +563,16 @@ tryEtaExpansion rhs bind_z_arg (arg, trivial_arg) | trivial_arg = returnSmpl (Nothing, arg) - | otherwise = newId (coreExprType arg) $ \ z -> + | otherwise = newId (exprType arg) $ \ z -> returnSmpl (Just (NonRec z arg), Var z) - -- Note: I used to try to avoid the coreExprType call by using + -- Note: I used to try to avoid the exprType call by using -- the type of the binder. But this type doesn't necessarily -- belong to the same substitution environment as this rhs; -- and we are going to make extra term binders (y_bndrs) from the type -- which will be processed with the rhs substitution environment. -- This only went wrong in a mind bendingly complicated case. - (potential_extra_arg_tys, inner_ty) = splitFunTys (coreExprType body) + (potential_extra_arg_tys, inner_ty) = splitFunTys (exprType body) y_tys :: [InType] y_tys = take no_extras_wanted potential_extra_arg_tys @@ -377,57 +614,6 @@ tryEtaExpansion rhs %************************************************************************ %* * -\subsection{Eta reduction} -%* * -%************************************************************************ - -@etaCoreExpr@ trys an eta reduction at the top level of a Core Expr. - -e.g. \ x y -> f x y ===> f - -It is used --- OLD --- a) Before constructing an Unfolding, to --- try to make the unfolding smaller; - b) In tidyCoreExpr, which is done just before converting to STG. - -But we only do this if - i) It gets rid of a whole lambda, not part. - The idea is that lambdas are often quite helpful: they indicate - head normal forms, so we don't want to chuck them away lightly. - --- OLD: in core2stg we want to do this even if the result isn't trivial --- ii) It exposes a simple variable or a type application; in short --- it exposes a "trivial" expression. (exprIsTrivial) - -\begin{code} -etaCoreExpr :: CoreExpr -> CoreExpr - -- ToDo: we should really check that we don't turn a non-bottom - -- lambda into a bottom variable. Sigh - -etaCoreExpr expr@(Lam bndr body) - = check (reverse binders) body - where - (binders, body) = collectBinders expr - - check [] body - | not (any (`elemVarSet` body_fvs) binders) - = body -- Success! - where - body_fvs = exprFreeVars body - - check (b : bs) (App fun arg) - | (varToCoreExpr b `cheapEqExpr` arg) - = check bs fun - - check _ _ = expr -- Bale out - -etaCoreExpr expr = expr -- The common case -\end{code} - - -%************************************************************************ -%* * \subsection{Case absorption and identity-case elimination} %* * %************************************************************************ @@ -503,13 +689,10 @@ mkCase scrut case_bndr alts = tick (CaseIdentity case_bndr) `thenSmpl_` returnSmpl scrut where - identity_alt (DEFAULT, [], Var v) = v == case_bndr - identity_alt (con, args, Con con' args') = con == con' && - and (zipWithEqual "mkCase" - cheapEqExpr - (map Type arg_tys ++ map varToCoreExpr args) - args') - identity_alt other = False + identity_alt (DEFAULT, [], Var v) = v == case_bndr + identity_alt (DataAlt con, args, rhs) = cheapEqExpr rhs + (mkConApp con (map Type arg_tys ++ map varToCoreExpr args)) + identity_alt other = False arg_tys = case splitTyConApp_maybe (idType case_bndr) of Just (tycon, arg_tys) -> arg_tys @@ -531,7 +714,7 @@ findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args ) findDefault (alt : alts) = case findDefault alts of (alts', deflt) -> (alt : alts', deflt) -findAlt :: Con -> [CoreAlt] -> CoreAlt +findAlt :: AltCon -> [CoreAlt] -> CoreAlt findAlt con alts = go alts where @@ -542,13 +725,3 @@ findAlt con alts matches (DEFAULT, _, _) = True matches (con1, _, _) = con == con1 \end{code} - - -\begin{code} -mkCoerce :: Type -> CoreExpr -> CoreExpr -mkCoerce to_ty expr - | to_ty == from_ty = expr - | otherwise = Note (Coerce to_ty from_ty) expr - where - from_ty = coreExprType expr -\end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 92fb9dd5b3..ba847de9b5 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -14,58 +14,61 @@ import CmdLineOpts ( intSwitchSet, switchIsOn, SimplifierSwitch(..) ) import SimplMonad -import SimplUtils ( mkCase, transformRhs, findAlt, etaCoreExpr, - simplBinder, simplBinders, simplIds, findDefault, mkCoerce +import SimplUtils ( mkCase, transformRhs, findAlt, + simplBinder, simplBinders, simplIds, findDefault, + SimplCont(..), DupFlag(..), contResultType, analyseCont, + discardInline, countArgs, countValArgs, discardCont, contIsDupable ) import Var ( TyVar, mkSysTyVar, tyVarKind, maybeModifyIdInfo ) import VarEnv import VarSet -import Id ( Id, idType, idInfo, idUnique, - getIdUnfolding, setIdUnfolding, isExportedId, - getIdSpecialisation, setIdSpecialisation, - getIdDemandInfo, setIdDemandInfo, +import Id ( Id, idType, idInfo, idUnique, isDataConId, isDataConId_maybe, + idUnfolding, setIdUnfolding, isExportedId, isDeadBinder, + idSpecialisation, setIdSpecialisation, + idDemandInfo, setIdDemandInfo, setIdInfo, - getIdOccInfo, setIdOccInfo, + idOccInfo, setIdOccInfo, zapLamIdInfo, zapFragileIdInfo, - getIdStrictness, + idStrictness, isBottomingId, setInlinePragma, mayHaveNoBinding, setOneShotLambda, maybeModifyIdInfo ) import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..), ArityInfo(..), atLeastArity, arityLowerBound, unknownArity, - specInfo, inlinePragInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo + specInfo, inlinePragInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo, + CprInfo(..), cprInfo ) import Demand ( Demand, isStrict, wwLazy ) -import Const ( isWHNFCon, conOkForAlt ) -import ConFold ( tryPrimOp ) -import PrimOp ( PrimOp, primOpStrictness, primOpType ) -import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConSig, dataConArgTys ) -import Const ( Con(..) ) +import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConRepArity, + dataConSig, dataConArgTys + ) import Name ( isLocallyDefined ) import CoreSyn import CoreFVs ( exprFreeVars ) -import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons, - callSiteInline, hasSomeUnfolding +import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons, maybeUnfoldingTemplate, + callSiteInline, hasSomeUnfolding, noUnfolding ) import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial, - coreExprType, coreAltsType, exprArity, exprIsValue, - exprOkForSpeculation + exprType, coreAltsType, exprArity, exprIsValue, idAppIsCheap, + exprOkForSpeculation, etaReduceExpr, + mkCoerce, mkSCC, mkInlineMe ) import Rules ( lookupRule ) import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC ) import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, seqType, - mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe, + mkFunTy, splitFunTy, splitFunTys, splitFunTy_maybe, + splitTyConApp_maybe, funResultTy, isDictTy, isDataType, applyTy, applyTys, mkFunTys ) import Subst ( Subst, mkSubst, emptySubst, substTy, substExpr, - substEnv, isInScope, lookupInScope, lookupIdSubst, substIdInfo + substEnv, isInScope, lookupIdSubst, substIdInfo ) import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel ) import Maybes ( maybeToBool ) -import Util ( zipWithEqual, stretchZipEqual, lengthExceeds ) +import Util ( zipWithEqual, lengthExceeds ) import PprCore import Outputable import Unique ( foldrIdKey ) -- Temp @@ -107,8 +110,8 @@ simplTopBinds binds simplRecBind :: Bool -> [(InId, InExpr)] -> [OutId] -> SimplM (OutStuff a) -> SimplM (OutStuff a) simplRecBind top_lvl pairs bndrs' thing_inside - = go pairs bndrs' `thenSmpl` \ (binds', stuff) -> - returnSmpl (addBind (Rec (flattenBinds binds')) stuff) + = go pairs bndrs' `thenSmpl` \ (binds', (binds'', res)) -> + returnSmpl (Rec (flattenBinds binds') : binds'', res) where go [] _ = thing_inside `thenSmpl` \ stuff -> returnSmpl ([], stuff) @@ -127,12 +130,30 @@ simplRecBind top_lvl pairs bndrs' thing_inside %************************************************************************ \begin{code} -addBind :: CoreBind -> OutStuff a -> OutStuff a -addBind bind (binds, res) = (bind:binds, res) +addLetBind :: OutId -> OutExpr -> SimplM (OutStuff a) -> SimplM (OutStuff a) +addLetBind bndr rhs thing_inside + = thing_inside `thenSmpl` \ (binds, res) -> + returnSmpl (NonRec bndr rhs : binds, res) + +addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a) +addLetBinds binds1 thing_inside + = thing_inside `thenSmpl` \ (binds2, res) -> + returnSmpl (binds1 ++ binds2, res) + +needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs) + -- Make a case expression instead of a let + -- These can arise either from the desugarer, + -- or from beta reductions: (\x.e) (x +# y) + +addCaseBind bndr rhs thing_inside + = getInScope `thenSmpl` \ in_scope -> + thing_inside `thenSmpl` \ (floats, (_, body)) -> + returnSmpl ([], (in_scope, Case rhs bndr [(DEFAULT, [], mkLets floats body)])) -addBinds :: [CoreBind] -> OutStuff a -> OutStuff a -addBinds [] stuff = stuff -addBinds binds1 (binds2, res) = (binds1++binds2, res) +addNonRecBind bndr rhs thing_inside + -- Checks for needing a case binding + | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside + | otherwise = addLetBind bndr rhs thing_inside \end{code} The reason for this OutExprStuff stuff is that we want to float *after* @@ -176,7 +197,7 @@ might do the same again. \begin{code} simplExpr :: CoreExpr -> SimplM CoreExpr simplExpr expr = getSubst `thenSmpl` \ subst -> - simplExprC expr (Stop (substTy subst (coreExprType expr))) + simplExprC expr (Stop (substTy subst (exprType expr))) -- The type in the Stop continuation is usually not used -- It's only needed when discarding continuations after finding -- a function that returns bottom. @@ -194,47 +215,26 @@ simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff simplExprF (Var v) cont = simplVar v cont -simplExprF expr@(Con (PrimOp op) args) cont - = getSubstEnv `thenSmpl` \ se -> - prepareArgs (ppr op) - (primOpType op) - (primOpStrictness op) - (pushArgs se args cont) $ \ args1 cont1 -> +simplExprF (Lit lit) (Select _ bndr alts se cont) + = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont - let - -- Boring... we may have too many arguments now, so we push them back - n_args = length args - args2 = ASSERT( length args1 >= n_args ) - take n_args args1 - cont2 = pushArgs emptySubstEnv (drop n_args args1) cont1 - in - -- Try the prim op simplification - -- It's really worth trying simplExpr again if it succeeds, - -- because you can find - -- case (eqChar# x 'a') of ... - -- ==> - -- case (case x of 'a' -> True; other -> False) of ... - - case tryPrimOp op args2 of - Just e' -> zapSubstEnv (simplExprF e' cont2) - Nothing -> rebuild (Con (PrimOp op) args2) cont2 - - -simplExprF (Con con@(DataCon _) args) cont - = simplConArgs args $ \ args' -> - rebuild (Con con args') cont - -simplExprF expr@(Con con@(Literal _) args) cont - = ASSERT( null args ) - rebuild expr cont +simplExprF (Lit lit) cont + = rebuild (Lit lit) cont simplExprF (App fun arg) cont = getSubstEnv `thenSmpl` \ se -> simplExprF fun (ApplyTo NoDup arg se cont) simplExprF (Case scrut bndr alts) cont - = getSubstEnv `thenSmpl` \ se -> - simplExprF scrut (Select NoDup bndr alts se cont) + = getSubst `thenSmpl` \ subst -> + getSwitchChecker `thenSmpl` \ chkr -> + if switchIsOn chkr NoCaseOfCase then + -- If case-of-case is off, simply simplify the scrutinee and rebuild + simplExprC scrut (Stop (substTy subst (idType bndr))) `thenSmpl` \ scrut' -> + rebuild_case False scrut' bndr alts (substEnv subst) cont + else + -- But if it's on, we simplify the scrutinee with a Select continuation + simplExprF scrut (Select NoDup bndr alts (substEnv subst) cont) simplExprF (Let (Rec pairs) body) cont @@ -276,7 +276,7 @@ simplExprF (Note (Coerce to from) e) cont simplExprF (Note (SCC cc) e) cont = setEnclosingCC currentCCS $ simplExpr e `thenSmpl` \ e -> - rebuild (mkNote (SCC cc) e) cont + rebuild (mkSCC cc e) cont simplExprF (Note InlineCall e) cont = simplExprF e (InlinePlease cont) @@ -303,7 +303,7 @@ simplExprF (Note InlineMe e) cont Stop _ -> -- Totally boring continuation -- Don't inline inside an INLINE expression switchOffInlining (simplExpr e) `thenSmpl` \ e' -> - rebuild (mkNote InlineMe e') cont + rebuild (mkInlineMe e') cont other -> -- Dissolve the InlineMe note if there's -- an interesting context of any kind to combine with @@ -330,13 +330,9 @@ simplLam fun cont -- Type-beta reduction go (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont) = ASSERT( isTyVar bndr ) - tick (BetaReduction bndr) `thenSmpl_` - getInScope `thenSmpl` \ in_scope -> - let - ty' = substTy (mkSubst in_scope arg_se) ty_arg - in - seqType ty' `seq` - extendSubst bndr (DoneTy ty') + tick (BetaReduction bndr) `thenSmpl_` + simplTyArg ty_arg arg_se `thenSmpl` \ ty_arg' -> + extendSubst bndr (DoneTy ty_arg') (go body body_cont) -- Ordinary beta reduction @@ -360,7 +356,7 @@ simplLam fun cont -- f = \x -> (coerce (\x -> e)) -- This made f's arity reduce, which is a bad thing, so I removed the -- eta reduction at this point, and now do it only when binding --- (at the call to postInlineUnconditionally +-- (at the call to postInlineUnconditionally) completeLam acc (Lam bndr body) cont = simplBinder bndr $ \ bndr' -> @@ -389,51 +385,6 @@ mkLamBndrZapper fun cont --------------------------------- -simplConArgs makes sure that the arguments all end up being atomic. -That means it may generate some Lets, hence the strange type - -\begin{code} -simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff -simplConArgs args thing_inside - = getSubst `thenSmpl` \ subst -> - go subst args thing_inside - where - go subst [] thing_inside - = thing_inside [] - go subst (arg:args) thing_inside - | exprIsTrivial arg - = let - arg1 = substExpr subst arg - -- Simplify the RHS with inlining switched off, so that - -- only absolutely essential things will happen. - -- If we don't do this, consider: - -- let x = e in C {x} - -- We end up inlining x back into C's argument, - -- and then let-binding it again! - -- - -- It's important that the substitution *does* deal with case-binder synonyms: - -- case x of y { True -> (x,1) } - -- Here we must be sure to substitute y for x when simplifying the args of the pair, - -- to increase the chances of being able to inline x. The substituter will do - -- that because the x->y mapping is held in the in-scope set. - in - ASSERT( exprIsTrivial arg1 ) - go subst args $ \ args1 -> - thing_inside (arg1 : args1) - - | otherwise - = -- If the argument ain't trivial, then let-bind it - simplExpr arg `thenSmpl` \ arg1 -> - newId (coreExprType arg1) $ \ arg_id -> - go subst args $ \ args1 -> - thing_inside (Var arg_id : args1) `thenSmpl` \ res -> - returnSmpl (addBind (NonRec arg_id arg1) res) - -- I used to use completeBeta but that was wrong, because - -- arg_id isn't an InId -\end{code} - - ---------------------------------- \begin{code} simplType :: InType -> SimplM OutType simplType ty @@ -477,33 +428,35 @@ simplBeta bndr rhs rhs_se cont_ty thing_inside | otherwise = -- Simplify the RHS simplBinder bndr $ \ bndr' -> - simplArg (idType bndr') (getIdDemandInfo bndr) - rhs rhs_se cont_ty $ \ rhs' -> + simplValArg (idType bndr') (idDemandInfo bndr) + rhs rhs_se cont_ty $ \ rhs' -> -- Now complete the binding and simplify the body - completeBeta bndr bndr' rhs' thing_inside - -completeBeta bndr bndr' rhs' thing_inside - | isUnLiftedType (idType bndr') && not (exprOkForSpeculation rhs') - -- Make a case expression instead of a let - -- These can arise either from the desugarer, - -- or from beta reductions: (\x.e) (x +# y) - = getInScope `thenSmpl` \ in_scope -> - thing_inside `thenSmpl` \ (floats, (_, body)) -> - returnSmpl ([], (in_scope, Case rhs' bndr' [(DEFAULT, [], mkLets floats body)])) - - | otherwise - = completeBinding bndr bndr' False False rhs' thing_inside + if needsCaseBinding (idType bndr') rhs' then + addCaseBind bndr' rhs' thing_inside + else + completeBinding bndr bndr' False False rhs' thing_inside \end{code} \begin{code} -simplArg :: OutType -> Demand - -> InExpr -> SubstEnv - -> OutType -- Type of thing computed by the context - -> (OutExpr -> SimplM OutExprStuff) - -> SimplM OutExprStuff -simplArg arg_ty demand arg arg_se cont_ty thing_inside +simplTyArg :: InType -> SubstEnv -> SimplM OutType +simplTyArg ty_arg se + = getInScope `thenSmpl` \ in_scope -> + let + ty_arg' = substTy (mkSubst in_scope se) ty_arg + in + seqType ty_arg' `seq` + returnSmpl ty_arg' + +simplValArg :: OutType -- Type of arg + -> Demand -- Demand on the argument + -> InExpr -> SubstEnv + -> OutType -- Type of thing computed by the context + -> (OutExpr -> SimplM OutExprStuff) + -> SimplM OutExprStuff + +simplValArg arg_ty demand arg arg_se cont_ty thing_inside | isStrict demand || isUnLiftedType arg_ty || (opt_DictsStrict && isDictTy arg_ty && isDataType arg_ty) @@ -524,7 +477,7 @@ simplArg arg_ty demand arg arg_se cont_ty thing_inside thing_inside -- Do eta-reduction on the simplified RHS, if eta reduction is on --- NB: etaCoreExpr only eta-reduces if that results in something trivial +-- NB: etaFirst only eta-reduces if that results in something trivial etaFirst | opt_SimplDoEtaReduction = \ thing_inside rhs -> thing_inside (etaCoreExprToTrivial rhs) | otherwise = \ thing_inside rhs -> thing_inside rhs @@ -534,7 +487,7 @@ etaFirst | opt_SimplDoEtaReduction = \ thing_inside rhs -> thing_inside (etaCore etaCoreExprToTrivial rhs | exprIsTrivial rhs' = rhs' | otherwise = rhs where - rhs' = etaCoreExpr rhs + rhs' = etaReduceExpr rhs \end{code} @@ -592,21 +545,21 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside -- We make new IdInfo for the new binder by starting from the old binder, -- doing appropriate substitutions. -- Then we add arity and unfolding info to get the new binder - new_bndr_info = substIdInfo subst (idInfo old_bndr) (idInfo new_bndr) + old_info = idInfo old_bndr + new_bndr_info = substIdInfo subst old_info (idInfo new_bndr) `setArityInfo` ArityAtLeast (exprArity new_rhs) - `setUnfoldingInfo` mkUnfolding top_lvl new_rhs + `setUnfoldingInfo` mkUnfolding top_lvl (cprInfo old_info) new_rhs final_id = new_bndr `setIdInfo` new_bndr_info in -- These seqs force the Ids, and hence the IdInfos, and hence any -- inner substitutions - final_id `seq` - - (modifyInScope new_bndr final_id thing_inside `thenSmpl` \ stuff -> - returnSmpl (addBind (NonRec final_id new_rhs) stuff)) + final_id `seq` + addLetBind final_id new_rhs $ + modifyInScope new_bndr final_id thing_inside where - occ_info = getIdOccInfo old_bndr + occ_info = idOccInfo old_bndr \end{code} @@ -678,8 +631,8 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside (floats_out, rhs'') | float_ubx = (floats, rhs') | otherwise = splitFloats floats rhs' in - if (top_lvl || exprIsCheap rhs') && -- Float lets if (a) we're at the top level - not (null floats_out) -- or (b) it exposes a cheap (i.e. duplicatable) expression + if (top_lvl || wantToExpose 0 rhs') && -- Float lets if (a) we're at the top level + not (null floats_out) -- or (b) the resulting RHS is one we'd like to expose then tickLetFloat floats_out `thenSmpl_` -- Do the float @@ -691,10 +644,11 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside -- and so there can't be any 'will be demanded' bindings in the floats. -- Hence the assert WARN( any demanded_float floats_out, ppr floats_out ) - setInScope in_scope' (etaFirst thing_inside rhs'') `thenSmpl` \ stuff -> + addLetBinds floats_out $ + setInScope in_scope' $ + etaFirst thing_inside rhs'' -- in_scope' may be excessive, but that's OK; -- it's a superset of what's in scope - returnSmpl (addBinds floats_out stuff) else -- Don't do the float etaFirst thing_inside (mkLets floats rhs') @@ -704,7 +658,7 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside tickLetFloat (NonRec b r : fs) = tick (LetFloatFromLet b) tickLetFloat (Rec ((b,r):prs) : fs) = tick (LetFloatFromLet b) -demanded_float (NonRec b r) = isStrict (getIdDemandInfo b) && not (isUnLiftedType (idType b)) +demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType (idType b)) -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them demanded_float (Rec _) = False @@ -721,6 +675,32 @@ splitFloats floats rhs must_stay (Rec prs) = False -- No unlifted bindings in here must_stay (NonRec b r) = isUnLiftedType (idType b) + +wantToExpose :: Int -> CoreExpr -> Bool +-- True for expressions that we'd like to expose at the +-- top level of an RHS. This includes partial applications +-- even if the args aren't cheap; the next pass will let-bind the +-- args and eta expand the partial application. So exprIsCheap won't do. +-- Here's the motivating example: +-- z = letrec g = \x y -> ...g... in g E +-- Even though E is a redex we'd like to float the letrec to give +-- g = \x y -> ...g... +-- z = g E +-- Now the next use of SimplUtils.tryEtaExpansion will give +-- g = \x y -> ...g... +-- z = let v = E in \w -> g v w +-- And now we'll float the v to give +-- g = \x y -> ...g... +-- v = E +-- z = \w -> g v w +-- Which is what we want; chances are z will be inlined now. +wantToExpose n (Var v) = idAppIsCheap v n +wantToExpose n (Lit l) = True +wantToExpose n (Lam _ e) = ASSERT( n==0 ) True -- We won't have applied \'s +wantToExpose n (Note _ e) = wantToExpose n e +wantToExpose n (App f (Type _)) = wantToExpose n f +wantToExpose n (App f a) = wantToExpose (n+1) f +wantToExpose n other = False -- There won't be any lets \end{code} @@ -742,23 +722,7 @@ simplVar var cont -- The mayHaveNoBinding test accouunts for the fact -- that class dictionary constructors dont have top level -- bindings and hence aren't in scope. - finish_var var1 occ - where - finish_var var occ - = getBlackList `thenSmpl` \ black_list -> - getInScope `thenSmpl` \ in_scope -> - completeCall black_list in_scope occ var cont - ---------------------------------------------------------- --- Dealing with a call - -completeCall black_list_fn in_scope occ var cont - - -- Look for an unfolding. There's a binding for the - -- thing, but perhaps we want to inline it anyway - | maybeToBool maybe_inline - = tick (UnfoldingDone var) `thenSmpl_` - zapSubstEnv (completeInlining var unf_template discard_inline_cont) + zapSubstEnv (completeCall var1 occ cont) -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider -- let x = e in @@ -767,12 +731,34 @@ completeCall black_list_fn in_scope occ var cont -- We'll clone the inner \x, adding x->x' in the id_subst -- Then when we inline y, we must *not* replace x by x' in -- the inlined copy!! - - | otherwise -- No inlining - -- Use prepareArgs to use function strictness - = prepareArgs (ppr var) (idType var) (get_str var) cont $ \ args' cont' -> - -- Look for rules or specialisations that match +--------------------------------------------------------- +-- Dealing with a call + +completeCall var occ cont + = getBlackList `thenSmpl` \ black_list_fn -> + getSwitchChecker `thenSmpl` \ chkr -> + getInScope `thenSmpl` \ in_scope -> + let + black_listed = black_list_fn var + (arg_infos, interesting_cont, inline_call) = analyseCont in_scope cont + discard_inline_cont | inline_call = discardInline cont + | otherwise = cont + + maybe_inline = callSiteInline black_listed inline_call occ + var arg_infos interesting_cont + in + -- First, look for an inlining + + case maybe_inline of { + Just unfolding -- There is an inlining! + -> tick (UnfoldingDone var) `thenSmpl_` + simplExprF unfolding discard_inline_cont + + ; + Nothing -> -- No inlining! + + -- Next, look for rules or specialisations that match -- -- It's important to simplify the args first, because the rule-matcher -- doesn't do substitution as it goes. We don't want to use subst_args @@ -785,83 +771,22 @@ completeCall black_list_fn in_scope occ var cont -- But the black-listing mechanism means that inlining of the wrapper -- won't occur for things that have specialisations till a later phase, so -- it's ok to try for inlining first. - getSwitchChecker `thenSmpl` \ chkr -> - if switchIsOn chkr DontApplyRules then - -- Don't try rules - rebuild (mkApps (Var var) args') cont' - else - -- Try rules first - case lookupRule in_scope var args' of + + prepareArgs (switchIsOn chkr NoCaseOfCase) var cont $ \ args' cont' -> + let + maybe_rule | switchIsOn chkr DontApplyRules = Nothing + | otherwise = lookupRule in_scope var args' + in + case maybe_rule of { Just (rule_name, rule_rhs) -> tick (RuleFired rule_name) `thenSmpl_` - zapSubstEnv (simplExprF rule_rhs cont') - -- See note above about zapping the substitution here + simplExprF rule_rhs cont' ; - Nothing -> rebuild (mkApps (Var var) args') cont' + Nothing -> -- No rules - where - get_str var = case getIdStrictness var of - NoStrictnessInfo -> (repeat wwLazy, False) - StrictnessInfo demands result_bot -> (demands, result_bot) - - ---------- Unfolding stuff - (subst_args, result_cont) = contArgs in_scope cont - val_args = filter isValArg subst_args - arg_infos = map (interestingArg in_scope) val_args - inline_call = contIsInline result_cont - interesting_cont = contIsInteresting result_cont - discard_inline_cont | inline_call = discardInline cont - | otherwise = cont - - maybe_inline = callSiteInline black_listed inline_call occ - var arg_infos interesting_cont - Just unf_template = maybe_inline - black_listed = black_list_fn var - - --- An argument is interesting if it has *some* structure --- We are here trying to avoid unfolding a function that --- is applied only to variables that have no unfolding --- (i.e. they are probably lambda bound): f x y z --- There is little point in inlining f here. -interestingArg in_scope (Type _) = False -interestingArg in_scope (App fn (Type _)) = interestingArg in_scope fn -interestingArg in_scope (Var v) = hasSomeUnfolding (getIdUnfolding v') - where - v' = case lookupVarSet in_scope v of - Just v' -> v' - other -> v -interestingArg in_scope other = True - - --- First a special case --- Don't actually inline the scrutinee when we see --- case x of y { .... } --- and x has unfolding (C a b). Why not? Because --- we get a silly binding y = C a b. If we don't --- inline knownCon can directly substitute x for y instead. -completeInlining var (Con con con_args) (Select _ bndr alts se cont) - | conOkForAlt con - = knownCon (Var var) con con_args bndr alts se cont - --- Now the normal case -completeInlining var unfolding cont - = simplExprF unfolding cont - ------------ costCentreOk --- costCentreOk checks that it's ok to inline this thing --- The time it *isn't* is this: --- --- f x = let y = E in --- scc "foo" (...y...) --- --- Here y has a "current cost centre", and we can't inline it inside "foo", --- regardless of whether E is a WHNF or not. - -costCentreOk ccs_encl cc_rhs - = not opt_SccProfilingOn - || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope - || not (isEmptyCC cc_rhs) -- otherwise need a cc on the unfolding + -- Done + rebuild (mkApps (Var var) args') cont' + }} \end{code} @@ -869,56 +794,103 @@ costCentreOk ccs_encl cc_rhs --------------------------------------------------------- -- Preparing arguments for a call -prepareArgs :: SDoc -- Error message info - -> OutType -> ([Demand],Bool) -> SimplCont +prepareArgs :: Bool -- True if the no-case-of-case switch is on + -> OutId -> SimplCont -> ([OutExpr] -> SimplCont -> SimplM OutExprStuff) -> SimplM OutExprStuff - -prepareArgs pp_fun orig_fun_ty (fun_demands, result_bot) orig_cont thing_inside +prepareArgs no_case_of_case fun orig_cont thing_inside = go [] demands orig_fun_ty orig_cont where - not_enough_args = fun_demands `lengthExceeds` countValArgs orig_cont - -- "No strictness info" is signalled by an infinite list of wwLazy - - demands | not_enough_args = repeat wwLazy -- Not enough args, or no strictness - | result_bot = fun_demands -- Enough args, and function returns bottom - | otherwise = fun_demands ++ repeat wwLazy -- Enough args and function does not return bottom - -- NB: demands is finite iff enough args and result_bot is True + orig_fun_ty = idType fun + is_data_con = isDataConId fun + + (demands, result_bot) + | no_case_of_case = ([], False) -- Ignore strictness info if the no-case-of-case + -- flag is on. Strictness changes evaluation order + -- and that can change full laziness + | otherwise + = case idStrictness fun of + StrictnessInfo demands result_bot + | not (demands `lengthExceeds` countValArgs orig_cont) + -> -- Enough args, use the strictness given. + -- For bottoming functions we used to pretend that the arg + -- is lazy, so that we don't treat the arg as an + -- interesting context. This avoids substituting + -- top-level bindings for (say) strings into + -- calls to error. But now we are more careful about + -- inlining lone variables, so its ok (see SimplUtils.analyseCont) + (demands, result_bot) + + other -> ([], False) -- Not enough args, or no strictness -- Main game plan: loop through the arguments, simplifying -- each of them in turn. We carry with us a list of demands, -- and the type of the function-applied-to-earlier-args + -- We've run out of demands, and the result is now bottom + -- This deals with + -- * case (error "hello") of { ... } + -- * (error "Hello") arg + -- * f (error "Hello") where f is strict + -- etc + go acc [] fun_ty cont + | result_bot + = tick_case_of_error cont `thenSmpl_` + thing_inside (reverse acc) (discardCont cont) + -- Type argument go acc ds fun_ty (ApplyTo _ arg@(Type ty_arg) se cont) + = simplTyArg ty_arg se `thenSmpl` \ new_ty_arg -> + go (Type new_ty_arg : acc) ds (applyTy fun_ty new_ty_arg) cont + + -- Value argument + go acc ds fun_ty (ApplyTo _ val_arg se cont) + | not is_data_con -- Function isn't a data constructor + = simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg -> + go (new_arg : acc) ds' res_ty cont + + | exprIsTrivial val_arg -- Function is a data contstructor, arg is trivial = getInScope `thenSmpl` \ in_scope -> let - ty_arg' = substTy (mkSubst in_scope se) ty_arg - res_ty = applyTy fun_ty ty_arg' + new_arg = substExpr (mkSubst in_scope se) val_arg + -- Simplify the RHS with inlining switched off, so that + -- only absolutely essential things will happen. + -- If we don't do this, consider: + -- let x = +# p q in C {x} + -- Even though x get's an occurrence of 'many', its RHS looks cheap, + -- and there's a good chance it'll get inlined back into C's RHS. Urgh! + -- + -- It's important that the substitution *does* deal with case-binder synonyms: + -- case x of y { True -> (x,1) } + -- Here we must be sure to substitute y for x when simplifying the args of the pair, + -- to increase the chances of being able to inline x. The substituter will do + -- that because the x->y mapping is held in the in-scope set. in - seqType ty_arg' `seq` - go (Type ty_arg' : acc) ds res_ty cont + -- It's not always the case that the new arg will be trivial + -- Consider f x + -- where, in one pass, f gets substituted by a constructor, + -- but x gets substituted by an expression (assume this is the + -- unique occurrence of x). It doesn't really matter -- it'll get + -- fixed up next pass. And it happens for dictionary construction, + -- which mentions the wrapper constructor to start with. - -- Value argument - go acc (d:ds) fun_ty (ApplyTo _ val_arg se cont) - = case splitFunTy_maybe fun_ty of { - Nothing -> pprTrace "prepareArgs" (pp_fun $$ ppr orig_fun_ty $$ ppr orig_cont) - (thing_inside (reverse acc) cont) ; - Just (arg_ty, res_ty) -> - simplArg arg_ty d val_arg se (contResultType cont) $ \ arg' -> - go (arg':acc) ds res_ty cont } - - -- We've run out of demands, which only happens for functions - -- we *know* now return bottom - -- This deals with - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - go acc [] fun_ty cont = tick_case_of_error cont `thenSmpl_` - thing_inside (reverse acc) (discardCont cont) + go (new_arg : acc) ds' res_ty cont + + | otherwise + = simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg -> + -- A data constructor whose argument is now non-trivial; + -- so let/case bind it. + newId arg_ty $ \ arg_id -> + addNonRecBind arg_id new_arg $ + go (Var arg_id : acc) ds' res_ty cont + + where + (arg_ty, res_ty) = splitFunTy fun_ty + (dem, ds') = case ds of + [] -> (wwLazy, []) + (d:ds) -> (d,ds) - -- We're run out of arguments + -- We're run out of arguments and the result ain't bottom go acc ds fun_ty cont = thing_inside (reverse acc) cont -- Boring: we must only record a tick if there was an interesting @@ -928,6 +900,7 @@ tick_case_of_error (CoerceIt _ (Stop _)) = returnSmpl () tick_case_of_error other = tick BottomFound \end{code} + %************************************************************************ %* * \subsection{Decisions about inlining} @@ -976,7 +949,7 @@ preInlineUnconditionally :: Bool {- Black listed -} -> InId -> Bool preInlineUnconditionally black_listed bndr | black_listed || opt_SimplNoPreInlining = False - | otherwise = case getIdOccInfo bndr of + | otherwise = case idOccInfo bndr of OneOcc in_lam once -> not in_lam && once -- Not inside a lambda, one occurrence ==> safe! other -> False @@ -1046,15 +1019,14 @@ rebuild expr cont@(ApplyTo _ arg se cont') -- Coerce continuation rebuild expr (CoerceIt to_ty cont) - = rebuild (mkCoerce to_ty expr) cont + = rebuild (mkCoerce to_ty (exprType expr) expr) cont -- Inline continuation rebuild expr (InlinePlease cont) = rebuild (Note InlineCall expr) cont rebuild scrut (Select _ bndr alts se cont) - = rebuild_case scrut bndr alts se cont - + = rebuild_case True scrut bndr alts se cont \end{code} Case elimination [see the code above] @@ -1139,19 +1111,49 @@ If so, then we can replace the case with one of the rhss. Blob of helper functions for the "case-of-something-else" situation. \begin{code} - --------------------------------------------------------- --- Case of known constructor or literal +-- Eliminate the case if possible -rebuild_case scrut@(Con con args) bndr alts se cont - | conOkForAlt con -- Knocks out PrimOps and NoRepLits - = knownCon scrut con args bndr alts se cont +rebuild_case add_eval_info scrut bndr alts se cont + | maybeToBool maybe_con_app + = knownCon scrut (DataAlt con) args bndr alts se cont ---------------------------------------------------------- --- Eliminate the case if possible + | canEliminateCase scrut bndr alts + = tick (CaseElim bndr) `thenSmpl_` ( + setSubstEnv se $ + simplBinder bndr $ \ bndr' -> + -- Remember to bind the case binder! + completeBinding bndr bndr' False False scrut $ + simplExprF (head (rhssOfAlts alts)) cont) + + | otherwise + = complete_case add_eval_info scrut bndr alts se cont -rebuild_case scrut bndr alts se cont - | -- Check that the RHSs are all the same, and + where + maybe_con_app = analyse (collectArgs scrut) + Just (con, args) = maybe_con_app + + analyse (Var fun, args) + | maybeToBool maybe_con_app = maybe_con_app + where + maybe_con_app = case isDataConId_maybe fun of + Just con | length args >= dataConRepArity con + -- Might be > because the arity excludes type args + -> Just (con, args) + other -> Nothing + + analyse (Var fun, []) + = case maybeUnfoldingTemplate (idUnfolding fun) of + Nothing -> Nothing + Just unf -> analyse (collectArgs unf) + + analyse other = Nothing + + + -- See if we can get rid of the case altogether + -- See the extensive notes on case-elimination above +canEliminateCase scrut bndr alts + = -- Check that the RHSs are all the same, and -- don't use the binders in the alternatives -- This test succeeds rapidly in the common case of -- a single DEFAULT alternative @@ -1179,34 +1181,21 @@ rebuild_case scrut bndr alts se cont -- other problems ) --- && opt_SimplDoCaseElim --- [June 99; don't test this flag. The code generator dies if it sees --- case (\x.e) of f -> ... --- so better to always do it - - -- Get rid of the case altogether - -- See the extensive notes on case-elimination above - -- Remember to bind the binder though! - = tick (CaseElim bndr) `thenSmpl_` ( - setSubstEnv se $ - simplBinder bndr $ \ bndr' -> - completeBinding bndr bndr' False False scrut $ - simplExprF rhs1 cont) - where - (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts] + (rhs1:other_rhss) = rhssOfAlts alts binders_unused (_, bndrs, _) = all isDeadBinder bndrs - var_demanded_later (Var v) = isStrict (getIdDemandInfo bndr) -- It's going to be evaluated later + var_demanded_later (Var v) = isStrict (idDemandInfo bndr) -- It's going to be evaluated later var_demanded_later other = False + --------------------------------------------------------- -- Case of something else -rebuild_case scrut case_bndr alts se cont +complete_case add_eval_info scrut case_bndr alts se cont = -- Prepare case alternatives prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr)) - scrut_cons alts `thenSmpl` \ better_alts -> + impossible_cons alts `thenSmpl` \ better_alts -> -- Set the new subst-env in place (before dealing with the case binder) setSubstEnv se $ @@ -1217,10 +1206,10 @@ rebuild_case scrut case_bndr alts se cont -- Deal with variable scrutinee - ( simplCaseBinder scrut case_bndr $ \ case_bndr' zap_occ_info -> + ( simplCaseBinder add_eval_info scrut case_bndr $ \ case_bndr' zap_occ_info -> -- Deal with the case alternatives - simplAlts zap_occ_info scrut_cons + simplAlts zap_occ_info impossible_cons case_bndr' better_alts cont' `thenSmpl` \ alts' -> mkCase scrut case_bndr' alts' @@ -1231,37 +1220,33 @@ rebuild_case scrut case_bndr alts se cont -- that should not include these chaps! rebuild_done case_expr where - -- scrut_cons tells what constructors the scrutinee can't possibly match - scrut_cons = case scrut of - Var v -> otherCons (getIdUnfolding v) - other -> [] + impossible_cons = case scrut of + Var v -> otherCons (idUnfolding v) + other -> [] + +knownCon :: OutExpr -> AltCon -> [OutExpr] + -> InId -> [InAlt] -> SubstEnv -> SimplCont + -> SimplM OutExprStuff knownCon expr con args bndr alts se cont = tick (KnownBranch bndr) `thenSmpl_` setSubstEnv se ( simplBinder bndr $ \ bndr' -> + completeBinding bndr bndr' False False expr $ + -- Don't use completeBeta here. The expr might be + -- an unboxed literal, like 3, or a variable + -- whose unfolding is an unboxed literal... and + -- completeBeta will just construct another case + -- expression! case findAlt con alts of (DEFAULT, bs, rhs) -> ASSERT( null bs ) - completeBinding bndr bndr' False False expr $ - -- Don't use completeBeta here. The expr might be - -- an unboxed literal, like 3, or a variable - -- whose unfolding is an unboxed literal... and - -- completeBeta will just construct another case - -- expression! simplExprF rhs cont - (Literal lit, bs, rhs) -> ASSERT( null bs ) - extendSubst bndr (DoneEx expr) $ - -- Unconditionally substitute, because expr must - -- be a variable or a literal. It can't be a - -- NoRep literal because they don't occur in - -- case patterns. + (LitAlt lit, bs, rhs) -> ASSERT( null bs ) simplExprF rhs cont - (DataCon dc, bs, rhs) -> ASSERT( length bs == length real_args ) - completeBinding bndr bndr' False False expr $ - -- See note above + (DataAlt dc, bs, rhs) -> ASSERT( length bs == length real_args ) extendSubstList bs (map mk real_args) $ simplExprF rhs cont where @@ -1290,6 +1275,17 @@ simplCaseBinder checks whether the scrutinee is a variable, v. If so, try to eliminate uses of v in the RHSs in favour of case_bndr; that way, there's a chance that v will now only be used once, and hence inlined. +There is a time we *don't* want to do that, namely when -fno-case-of-case +is on. This happens in the first simplifier pass, and enhances full laziness. +Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) +If we eliminate the inner case, we trap it inside the I# v -> arm, +which might prevent some full laziness happening. I've seen this +in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] +Hence the add_eval_info argument + + If we do this, then we have to nuke any occurrence info (eg IAmDead) in the case binder, because the case-binder now effectively occurs whenever v does. AND we have to do the same for the pattern-bound @@ -1306,7 +1302,8 @@ Urk! b is alive! Reason: the scrutinee was a variable, and case elimination happened. Hence the zap_occ_info function returned by simplCaseBinder \begin{code} -simplCaseBinder (Var v) case_bndr thing_inside +simplCaseBinder add_eval_info (Var v) case_bndr thing_inside + | add_eval_info = simplBinder (zap case_bndr) $ \ case_bndr' -> modifyInScope v case_bndr' $ -- We could extend the substitution instead, but it would be @@ -1316,7 +1313,7 @@ simplCaseBinder (Var v) case_bndr thing_inside where zap b = b `setIdOccInfo` NoOccInfo -simplCaseBinder other_scrut case_bndr thing_inside +simplCaseBinder add_eval_info other_scrut case_bndr thing_inside = simplBinder case_bndr $ \ case_bndr' -> thing_inside case_bndr' (\ bndr -> bndr) -- NoOp on bndr \end{code} @@ -1352,7 +1349,7 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts newIds (dataConArgTys data_con (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs -> - returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt) + returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt) other -> returnSmpl filtered_alts where @@ -1363,8 +1360,8 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts missing_cons = [data_con | data_con <- tyConDataCons tycon, not (data_con `elem` handled_data_cons)] - handled_data_cons = [data_con | DataCon data_con <- scrut_cons] ++ - [data_con | (DataCon data_con, _, _) <- filtered_alts] + handled_data_cons = [data_con | DataAlt data_con <- scrut_cons] ++ + [data_con | (DataAlt data_con, _, _) <- filtered_alts] -- The default case prepareCaseAlts _ _ scrut_cons alts @@ -1399,11 +1396,11 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont' -- doing simplBinders simplBinders (add_evals con vs) $ \ vs' -> - -- Bind the case-binder to (Con args) + -- Bind the case-binder to (con args) let - con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs') + unfolding = mkUnfolding False NoCPRInfo (mkAltExpr con vs' inst_tys') in - modifyInScope case_bndr' (case_bndr' `setIdUnfolding` mkUnfolding False con_app) $ + modifyInScope case_bndr' (case_bndr' `setIdUnfolding` unfolding) $ simplExprC rhs cont' `thenSmpl` \ rhs' -> returnSmpl (con, vs', rhs') @@ -1417,7 +1414,7 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont' -- We really must record that b is already evaluated so that we don't -- go and re-evaluate it when constructing the result. - add_evals (DataCon dc) vs = cat_evals vs (dataConRepStrictness dc) + add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc) add_evals other_con vs = vs cat_evals [] [] = [] @@ -1461,7 +1458,7 @@ mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside ) `thenSmpl` \ join_rhs -> -- Build the join Id and continuation - newId (coreExprType join_rhs) $ \ join_id -> + newId (exprType join_rhs) $ \ join_id -> let new_cont = ArgOf OkToDup cont_ty (\arg' -> rebuild_done (App (Var join_id) arg')) @@ -1471,8 +1468,7 @@ mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside -- Want to tick here so that we go round again, -- and maybe copy or inline the code; -- not strictly CaseOf Case - thing_inside new_cont `thenSmpl` \ res -> - returnSmpl (addBind (NonRec join_id join_rhs) res) + addLetBind join_id join_rhs (thing_inside new_cont) mkDupableCont ty (ApplyTo _ arg se cont) thing_inside = mkDupableCont (funResultTy ty) cont $ \ cont' -> @@ -1480,14 +1476,21 @@ mkDupableCont ty (ApplyTo _ arg se cont) thing_inside if exprIsDupable arg' then thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont') else - newId (coreExprType arg') $ \ bndr -> + newId (exprType arg') $ \ bndr -> tick (CaseOfCase bndr) `thenSmpl_` -- Want to tick here so that we go round again, -- and maybe copy or inline the code; -- not strictly CaseOf Case - thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res -> - returnSmpl (addBind (NonRec bndr arg') res) + + addLetBind bndr arg' $ + -- But what if the arg should be case-bound? We can't use + -- addNonRecBind here because its type is too specific. + -- This has been this way for a long time, so I'll leave it, + -- but I can't convince myself that it's right. + + thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') + mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside = tick (CaseOfCase case_bndr) `thenSmpl_` @@ -1507,10 +1510,8 @@ mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside -- This is VITAL when the type of case_bndr is an unboxed pair (often the -- case in I/O rich code. We aren't allowed a lambda bound -- arg of unboxed tuple type, and indeed such a case_bndr is always dead - thing_inside (Select OkToDup case_bndr alts' se (Stop (contResultType cont))) `thenSmpl` \ res -> - - returnSmpl (addBinds alt_binds res) - + addLetBinds alt_binds $ + thing_inside (Select OkToDup case_bndr alts' se (Stop (contResultType cont))) mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt) mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) @@ -1539,7 +1540,7 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) else let - rhs_ty' = coreExprType rhs' + rhs_ty' = exprType rhs' (used_bndrs, used_bndrs') = unzip [pr | pr@(bndr,bndr') <- zip (case_bndr : bndrs) (case_bndr' : bndrs'), diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 09d10b99ea..20c6c10638 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -11,7 +11,7 @@ module LambdaLift ( liftProgram ) where import StgSyn import Bag ( Bag, emptyBag, unionBags, unitBag, snocBag, bagToList ) -import Id ( mkVanillaId, idType, setIdArity, Id ) +import Id ( mkVanillaId, idType, setIdArityInfo, Id ) import VarSet import VarEnv import IdInfo ( exactArity ) @@ -144,7 +144,9 @@ liftExpr :: StgExpr -> LiftM (StgExpr, LiftInfo) -liftExpr expr@(StgCon con args _) = returnLM (expr, emptyLiftInfo) +liftExpr expr@(StgLit _) = returnLM (expr, emptyLiftInfo) +liftExpr expr@(StgConApp _ _) = returnLM (expr, emptyLiftInfo) +liftExpr expr@(StgPrimApp _ _ _) = returnLM (expr, emptyLiftInfo) liftExpr expr@(StgApp v args) = lookUp v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to @@ -442,7 +444,7 @@ newSupercombinator :: Type newSupercombinator ty arity mod ci us idenv = mkVanillaId (mkTopName uniq mod SLIT("_ll")) ty - `setIdArity` exactArity arity + `setIdArityInfo` exactArity arity -- ToDo: rm the setIdArity? Just let subsequent stg-saturation pass do it? where uniq = uniqFromSupply us diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs index 3cf92e5f26..54b3a358d6 100644 --- a/ghc/compiler/simplStg/SRT.lhs +++ b/ghc/compiler/simplStg/SRT.lhs @@ -9,9 +9,9 @@ bindings have no CAF references, and record the fact in their IdInfo. \begin{code} module SRT where -import Id ( Id, setIdCafInfo, getIdCafInfo, externallyVisibleId, - idAppIsBottom +import Id ( Id, setIdCafInfo, idCafInfo, externallyVisibleId, ) +import CoreUtils( idAppIsBottom ) import IdInfo ( CafInfo(..) ) import StgSyn @@ -223,7 +223,12 @@ srtExpr rho (cont,lne) off e@(StgApp f args) = (e, global_refs, [], off) getGlobalRefs rho (StgVarArg f:args) `unionUniqSets` lookupPossibleLNE lne f -srtExpr rho (cont,lne) off e@(StgCon con args ty) = +srtExpr rho (cont,lne) off e@(StgLit l) = (e, cont, [], off) + +srtExpr rho (cont,lne) off e@(StgConApp con args) = + (e, cont `unionUniqSets` getGlobalRefs rho args, [], off) + +srtExpr rho (cont,lne) off e@(StgPrimApp op args ty) = (e, cont `unionUniqSets` getGlobalRefs rho args, [], off) srtExpr rho c@(cont,lne) off (StgCase scrut live1 live2 uniq _{-srt-} alts) = @@ -445,11 +450,12 @@ globalRefArg rho (StgVarArg id) | otherwise = case lookupUFM rho id of { - Just _ -> [id]; -- can't look at the caf_info yet... - Nothing -> + Just _ -> [id]; -- Can't look at the caf_info yet... + Nothing -> -- but we will look it up and filter later + -- in maybeHaveCafRefs if externallyVisibleId id - then case getIdCafInfo id of + then case idCafInfo id of MayHaveCafRefs -> [id] NoCafRefs -> [] else [] diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs index fc9da5d3f8..fd5946a3fe 100644 --- a/ghc/compiler/simplStg/StgStats.lhs +++ b/ghc/compiler/simplStg/StgStats.lhs @@ -27,7 +27,6 @@ module StgStats ( showStgStats ) where import StgSyn -import Const ( Con(..) ) import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap ) import Id (Id) \end{code} @@ -149,20 +148,11 @@ statRhs top (b, StgRhsClosure cc bi srt fv u args body) \begin{code} statExpr :: StgExpr -> StatEnv -statExpr (StgApp _ _) - = countOne Applications - -statExpr (StgCon (DataCon _) as _) - = countOne ConstructorApps - -statExpr (StgCon (PrimOp _) as _) - = countOne PrimitiveApps - -statExpr (StgCon (Literal _) as _) - = countOne Literals - -statExpr (StgSCC l e) - = statExpr e +statExpr (StgApp _ _) = countOne Applications +statExpr (StgLit _) = countOne Literals +statExpr (StgConApp _ _) = countOne ConstructorApps +statExpr (StgPrimApp _ _ _) = countOne PrimitiveApps +statExpr (StgSCC l e) = statExpr e statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body) = statBinding False{-not top-level-} binds `combineSE` diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index 27756b79b7..350ef60051 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -13,14 +13,13 @@ module StgVarInfo ( setStgVarInfo ) where import StgSyn -import Id ( setIdArity, getIdArity, setIdOccInfo, Id ) +import Id ( setIdArityInfo, idArity, setIdOccInfo, Id ) import VarSet import VarEnv import Var -import Const ( Con(..) ) import IdInfo ( ArityInfo(..), OccInfo(..), setInlinePragInfo ) -import PrimOp ( PrimOp(..) ) +import PrimOp ( PrimOp(..), ccallMayGC ) import TysWiredIn ( isForeignObjTy ) import Maybes ( maybeToBool, orElse ) import Name ( isLocallyDefined ) @@ -129,7 +128,7 @@ varsTopBinds (bind:binds) StgNonRec binder rhs -> [(binder,rhs)] StgRec pairs -> pairs - binders' = [ binder `setIdArity` ArityExactly (rhsArity rhs) + binders' = [ binder `setIdArityInfo` ArityExactly (rhsArity rhs) | (binder, rhs) <- pairs ] @@ -212,13 +211,8 @@ to do it before the SRT pass to save the SRT entries associated with any top-level PAPs. \begin{code} -isPAP (StgApp f args) - = case getIdArity f of - ArityExactly n -> n > n_args - ArityAtLeast n -> n > n_args - _ -> False - where n_args = length args -isPAP _ = False +isPAP (StgApp f args) = idArity f > length args +isPAP _ = False \end{code} \begin{code} @@ -232,10 +226,10 @@ varsAtoms atoms = mapAndUnzipLne var_atom atoms `thenLne` \ (args', fvs_lists) -> returnLne (args', unionFVInfos fvs_lists) where - var_atom a@(StgConArg _) = returnLne (a, emptyFVInfo) var_atom a@(StgVarArg v) = lookupVarLne v `thenLne` \ (v', how_bound) -> returnLne (StgVarArg v', singletonFVInfo v' how_bound stgArgOcc) + var_atom a = returnLne (a, emptyFVInfo) \end{code} %************************************************************************ @@ -272,12 +266,17 @@ on these components, but it in turn is not scrutinised as the basis for any decisions. Hence no black holes. \begin{code} +varsExpr (StgLit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet) + varsExpr (StgApp f args) = varsApp Nothing f args -varsExpr (StgCon con args res_ty) - = getVarsLiveInCont `thenLne` \ live_in_cont -> - varsAtoms args `thenLne` \ (args', args_fvs) -> - returnLne (StgCon con args' res_ty, args_fvs, getFVSet args_fvs) +varsExpr (StgConApp con args) + = varsAtoms args `thenLne` \ (args', args_fvs) -> + returnLne (StgConApp con args', args_fvs, getFVSet args_fvs) + +varsExpr (StgPrimApp op args res_ty) + = varsAtoms args `thenLne` \ (args', args_fvs) -> + returnLne (StgPrimApp op args' res_ty, args_fvs, getFVSet args_fvs) varsExpr (StgSCC cc expr) = varsExpr expr `thenLne` ( \ (expr2, fvs, escs) -> @@ -302,9 +301,10 @@ varsExpr (StgCase scrut _ _ bndr srt alts) -- in the alts to achieve the desired effect. mb_live_across_case = case scrut of - StgCon (PrimOp (CCallOp _ _ True{- _ccall_GC_ -} _)) args _ -> - Just (foldl findLiveArgs emptyVarSet args) - _ -> Nothing + StgPrimApp (CCallOp ccall) args _ + | ccallMayGC ccall + -> Just (foldl findLiveArgs emptyVarSet args) + _ -> Nothing -- don't consider the default binder as being 'live in alts', -- since this is from the point of view of the case expr, where @@ -413,10 +413,10 @@ call. This only an issue \begin{code} findLiveArgs :: StgLiveVars -> StgArg -> StgLiveVars -findLiveArgs lvs (StgConArg _) = lvs findLiveArgs lvs (StgVarArg x) | isForeignObjTy (idType x) = extendVarSet lvs x | otherwise = lvs +findLiveArgs lvs arg = lvs \end{code} @@ -440,42 +440,35 @@ varsApp maybe_thunk_body f args let n_args = length args not_letrec_bound = not (isLetrecBound how_bound) - f_arity = getIdArity f' + f_arity = idArity f' -- Will have an exact arity by now fun_fvs = singletonFVInfo f' how_bound fun_occ fun_occ - | not_letrec_bound - = NoStgBinderInfo -- Uninteresting variable - - | otherwise -- Letrec bound; must have its arity - = case f_arity of - ArityExactly arity - | n_args == 0 -> stgFakeFunAppOcc -- Function Application - -- with no arguments. - -- used by the lambda lifter. - | arity > n_args -> stgUnsatOcc -- Unsaturated - - - | arity == n_args && - maybeToBool maybe_thunk_body -> -- Exactly saturated, - -- and rhs of thunk - case maybe_thunk_body of - Just Updatable -> stgStdHeapOcc - Just SingleEntry -> stgNoUpdHeapOcc - other -> panic "varsApp" - - | otherwise -> stgNormalOcc + | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable + + -- Otherwise it is letrec bound; must have its arity + | n_args == 0 = stgFakeFunAppOcc -- Function Application + -- with no arguments. + -- used by the lambda lifter. + | f_arity > n_args = stgUnsatOcc -- Unsaturated + + + | f_arity == n_args && + maybeToBool maybe_thunk_body -- Exactly saturated, + -- and rhs of thunk + = case maybe_thunk_body of + Just Updatable -> stgStdHeapOcc + Just SingleEntry -> stgNoUpdHeapOcc + other -> panic "varsApp" + + | otherwise = stgNormalOcc -- Record only that it occurs free myself = unitVarSet f' - fun_escs | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting - | otherwise = case f_arity of -- Letrec bound, so must have its arity - ArityExactly arity - | arity == n_args -> emptyVarSet - -- Function doesn't escape - | otherwise -> myself - -- Inexact application; it does escape + fun_escs | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting + | f_arity == n_args = emptyVarSet -- Function doesn't escape + | otherwise = myself -- Inexact application; it does escape -- At the moment of the call: @@ -591,7 +584,7 @@ vars_let let_no_escape bind body StgRec pairs -> map fst pairs mk_binding bind_lvs (binder,rhs) - = (binder `setIdArity` ArityExactly (stgArity rhs), + = (binder `setIdArityInfo` ArityExactly (stgArity rhs), LetrecBound False -- Not top level live_vars ) @@ -834,7 +827,7 @@ rhsArity (StgRhsCon _ _ _) = 0 rhsArity (StgRhsClosure _ _ _ _ _ args _) = length args zapArity :: Id -> Id -zapArity id = id `setIdArity` UnknownArity +zapArity id = id `setIdArityInfo` UnknownArity \end{code} diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs index 5c670ad47c..b79ea19731 100644 --- a/ghc/compiler/simplStg/UpdAnal.lhs +++ b/ghc/compiler/simplStg/UpdAnal.lhs @@ -18,7 +18,7 @@ import StgSyn import VarEnv import VarSet import Id ( mkSysLocal, - getIdUpdateInfo, setIdUpdateInfo, idType, + idUpdateInfo, setIdUpdateInfo, idType, externallyVisibleId, Id ) @@ -128,7 +128,7 @@ lookup v Nothing -> unknownClosure | otherwise - = const (case updateInfoMaybe (getIdUpdateInfo v) of + = const (case updateInfoMaybe (idUpdateInfo v) of Nothing -> unknownClosure Just spec -> convertUpdateSpec spec) \end{code} @@ -205,7 +205,7 @@ data structure, or something else that we know nothing about. udData :: [StgArg] -> CaseBoundVars -> AbVal udData vs cvs = \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom) - where local_ids = [ lookup v | (StgVarArg v) <- vs, v `notCaseBound` cvs ] + where local_ids = [ lookup v | StgVarArg v <- vs, v `notCaseBound` cvs ] \end{code} %----------------------------------------------------------------------------- @@ -230,9 +230,11 @@ ud :: StgExpr -- Expression to be analysed -> IdEnvClosure -- Current environment -> (StgExpr, AbVal) -- (New expression, abstract value) -ud e@(StgCon _ vs _) cvs p = (e, udData vs cvs) -ud e@(StgSCC lab a) cvs p = ud a cvs p =: \(a', abval_a) -> - (StgSCC lab a', abval_a) +ud e@(StgLit _) cvs p = (e, udData [] cvs) +ud e@(StgConApp _ vs) cvs p = (e, udData vs cvs) +ud e@(StgPrimApp _ vs _) cvs p = (e, udData vs cvs) +ud e@(StgSCC lab a) cvs p = ud a cvs p =: \(a', abval_a) -> + (StgSCC lab a', abval_a) \end{code} Here is application. The first thing to do is analyse the head, and @@ -403,7 +405,7 @@ udBinding (StgRec ve) cvs p (v,(v,rhs'), abval) collectfv (_, StgRhsClosure _ _ _ fv _ _ _) = fv - collectfv (_, StgRhsCon _ con args) = [ v | (StgVarArg v) <- args ] + collectfv (_, StgRhsCon _ con args) = [ v | StgVarArg v <- args ] \end{code} %----------------------------------------------------------------------------- diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index f1578c2150..3777e076c2 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -14,7 +14,6 @@ module Rules ( #include "HsVersions.h" import CoreSyn -- All of it -import Const ( Con(..), Literal(..) ) import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails ) import BinderInfo ( markMany ) import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars ) @@ -25,8 +24,8 @@ import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst, mkSubst, substEnv, setSubstEnv, emptySubst, isInScope, unBindSubst, bindSubstList, unBindSubstList, substInScope ) -import Id ( Id, getIdUnfolding, zapLamIdInfo, - getIdSpecialisation, setIdSpecialisation, +import Id ( Id, idUnfolding, zapLamIdInfo, + idSpecialisation, setIdSpecialisation, setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo ) import IdInfo ( setSpecInfo, specInfo ) @@ -220,7 +219,7 @@ zapOccInfo bndr | isTyVar bndr = bndr \end{code} \begin{code} -type Matcher result = IdOrTyVarSet -- Template variables +type Matcher result = VarSet -- Template variables -> (Subst -> Maybe result) -- Continuation if success -> Subst -> Maybe result -- Substitution so far -> result -- The *SubstEnv* in these Substs apply to the TEMPLATE only @@ -253,9 +252,9 @@ match (Var v1) e2 tpl_vars kont subst other -> match_fail -match (Con c1 es1) (Con c2 es2) tpl_vars kont subst - | c1 == c2 - = matches es1 es2 tpl_vars kont subst +match (Lit lit1) (Lit lit2) tpl_vars kont subst + | lit1 == lit2 + = kont subst match (App f1 a1) (App f2 a2) tpl_vars kont subst = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst @@ -325,7 +324,7 @@ match e1 (Var v2) tpl_vars kont subst | isCheapUnfolding unfolding = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst where - unfolding = getIdUnfolding v2 + unfolding = idUnfolding v2 -- We can't cope with lets in the template @@ -439,7 +438,7 @@ addIdSpecialisations id spec_stuff = setIdSpecialisation id new_rules where rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id)) - new_rules = foldr add (getIdSpecialisation id) spec_stuff + new_rules = foldr add (idSpecialisation id) spec_stuff add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs) \end{code} @@ -462,12 +461,12 @@ pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) lookupRule in_scope fn args - = case getIdSpecialisation fn of + = case idSpecialisation fn of Rules rules _ -> matchRules in_scope rules args orphanRule :: ProtoCoreRule -> Bool -- An "orphan rule" is one that is defined in this --- module, but of ran *imported* function. We need +-- module, but for an *imported* function. We need -- to track these separately when generating the interface file orphanRule (ProtoCoreRule local fn _) = local && not (isLocallyDefined fn) @@ -533,5 +532,5 @@ add_rule (ProtoCoreRule _ id rule) -- Find *all* the free Ids of the LHS, not just -- locally defined ones!! -addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule) +addRuleToId id rule = setIdSpecialisation id (addRule id (idSpecialisation id) rule) \end{code} diff --git a/ghc/compiler/specialise/SpecEnv.hi-boot-5 b/ghc/compiler/specialise/SpecEnv.hi-boot-5 index f08f94557a..c02426ed9e 100644 --- a/ghc/compiler/specialise/SpecEnv.hi-boot-5 +++ b/ghc/compiler/specialise/SpecEnv.hi-boot-5 @@ -3,5 +3,5 @@ __export SpecEnv SpecEnv emptySpecEnv specEnvFreeVars isEmptySpecEnv ; 1 data SpecEnv a; 1 emptySpecEnv :: __forall [a] => SpecEnv a ; 1 isEmptySpecEnv :: __forall [a] => SpecEnv a -> PrelBase.Bool ; -1 specEnvFreeVars :: __forall [a] => (a -> VarSet.IdOrTyVarSet) -> SpecEnv a -> VarSet.IdOrTyVarSet ; +1 specEnvFreeVars :: __forall [a] => (a -> VarSet.VarSet) -> SpecEnv a -> VarSet.VarSet ; diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 5edea2fcfe..3154df7729 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -10,8 +10,8 @@ module Specialise ( specProgram ) where import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_spec, opt_D_dump_rules ) import Id ( Id, idName, idType, mkTemplateLocals, mkUserLocal, - getIdSpecialisation, setIdNoDiscard, isExportedId, - modifyIdInfo + idSpecialisation, setIdNoDiscard, isExportedId, + modifyIdInfo, idUnfolding ) import IdInfo ( zapSpecPragInfo ) import VarSet @@ -28,7 +28,8 @@ import Var ( TyVar, mkSysTyVar, setVarUnique ) import VarSet import VarEnv import CoreSyn -import CoreUtils ( coreExprType, applyTypeToArgs ) +import CoreUtils ( applyTypeToArgs ) +import CoreUnfold ( certainlyWillInline ) import CoreFVs ( exprFreeVars, exprsFreeVars ) import CoreLint ( beginPass, endPass ) import PprCore ( pprCoreRules ) @@ -598,7 +599,7 @@ specProgram us binds specBind emptySubst bind uds `thenSM` \ (bind', uds') -> returnSM (bind' ++ binds', uds') -dump_specs var = pprCoreRules var (getIdSpecialisation var) +dump_specs var = pprCoreRules var (idSpecialisation var) \end{code} %************************************************************************ @@ -623,10 +624,7 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) ---------------- First the easy cases -------------------- specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs) specExpr subst (Var v) = returnSM (specVar subst v, emptyUDs) - -specExpr subst e@(Con con args) - = mapAndCombineSM (specExpr subst) args `thenSM` \ (args', uds) -> - returnSM (Con con args', uds) +specExpr subst (Lit lit) = returnSM (Lit lit, emptyUDs) specExpr subst (Note note body) = specExpr subst body `thenSM` \ (body', uds) -> @@ -787,6 +785,9 @@ specDefn subst calls (fn, rhs) | n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas && n_dicts <= length rhs_bndrs -- and enough dict args && not (null calls_for_me) -- And there are some calls to specialise + && not (certainlyWillInline fn) -- And it's not small + -- If it's small, it's better just to inline + -- it than to construct lots of specialisations = -- Specialise the body of the function specExpr subst rhs `thenSM` \ (rhs', rhs_uds) -> @@ -828,7 +829,7 @@ specDefn subst calls (fn, rhs) ---------------------------------------------------------- -- Specialise to one particular call pattern - spec_call :: ([Maybe Type], ([DictExpr], IdOrTyVarSet)) -- Call instance + spec_call :: ([Maybe Type], ([DictExpr], VarSet)) -- Call instance -> SpecM ((Id,CoreExpr), -- Specialised definition UsageDetails, -- Usage details from specialised body ([CoreBndr], [CoreExpr], CoreExpr)) -- Info for the Id's SpecEnv @@ -908,7 +909,7 @@ data UsageDetails calls :: !CallDetails } -type DictBind = (CoreBind, IdOrTyVarSet) +type DictBind = (CoreBind, VarSet) -- The set is the free vars of the binding -- both tyvars and dicts @@ -917,13 +918,13 @@ type DictExpr = CoreExpr emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM } type ProtoUsageDetails = ([DictBind], - [(Id, [Maybe Type], ([DictExpr], IdOrTyVarSet))] + [(Id, [Maybe Type], ([DictExpr], VarSet))] ) ------------------------------------------------------------ type CallDetails = FiniteMap Id CallInfo type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument - ([DictExpr], IdOrTyVarSet) -- Dict args and the vars of the whole + ([DictExpr], VarSet) -- Dict args and the vars of the whole -- call (including tyvars) -- [*not* include the main id itself, of course] -- The finite maps eliminate duplicates diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 271615fdb0..e243c2bb5b 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -17,28 +17,31 @@ module CoreToStg ( topCoreBindsToStg ) where import CoreSyn -- input import StgSyn -- output -import CoreUtils ( coreExprType ) +import CoreUtils ( exprType ) import SimplUtils ( findDefault ) import CostCentre ( noCCS ) -import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId, mkVanillaId, - externallyVisibleId, setIdUnique, idName, getIdDemandInfo, setIdType +import Id ( Id, mkSysLocal, idType, idStrictness, idUnique, isExportedId, mkVanillaId, + externallyVisibleId, setIdUnique, idName, + idDemandInfo, idArity, setIdType, idFlavour ) import Var ( Var, varType, modifyIdInfo ) -import IdInfo ( setDemandInfo, StrictnessInfo(..) ) +import IdInfo ( setDemandInfo, StrictnessInfo(..), IdFlavour(..) ) import UsageSPUtils ( primOpUsgTys ) -import DataCon ( DataCon, dataConName, dataConId ) +import DataCon ( DataCon, dataConName, isDynDataCon, dataConWrapId ) import Demand ( Demand, isStrict, wwStrict, wwLazy ) import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique ) import Module ( isDynamicModule ) -import Const ( Con(..), Literal(..), isLitLitLit, conStrictness, isWHNFCon ) +import Literal ( Literal(..) ) import VarEnv -import PrimOp ( PrimOp(..), primOpUsg, primOpSig ) +import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..), primOpUsg ) import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe, - UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType ) + UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType, + splitRepFunTys, mkFunTys + ) import TysPrim ( intPrimTy ) import UniqSupply -- all of it, really import Util ( lengthExceeds ) -import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity ) import CmdLineOpts ( opt_D_verbose_stg2stg, opt_UsageSPOn ) import UniqSet ( emptyUniqSet ) import Maybes @@ -154,7 +157,7 @@ isOnceTy ty UsVar uv -> pprPanic "CoreToStg: unexpected uvar annot:" (ppr uv) bdrDem :: Id -> RhsDemand -bdrDem id = mkDem (getIdDemandInfo id) (isOnceTy (idType id)) +bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id)) safeDem, onceDem :: RhsDemand safeDem = RhsDemand False False -- always safe to use this @@ -221,7 +224,7 @@ topCoreBindsToStg us core_binds coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv) coreBindToStg top_lev env (NonRec binder rhs) - = coreExprToStgFloat env rhs dem `thenUs` \ (floats, stg_rhs) -> + = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) -> case (floats, stg_rhs) of ([], StgApp var []) | not (isExportedId binder) -> returnUs (NoBindF, extendVarEnv env binder var) @@ -236,18 +239,17 @@ coreBindToStg top_lev env (NonRec binder rhs) where dem = bdrDem binder + coreBindToStg top_lev env (Rec pairs) = newLocalIds top_lev env binders `thenUs` \ (env', binders') -> mapUs (do_rhs env') pairs `thenUs` \ stg_rhss -> returnUs (RecF (binders' `zip` stg_rhss), env') where binders = map fst pairs - do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs dem `thenUs` \ (floats, stg_expr) -> + do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_expr) -> mkStgBinds floats stg_expr `thenUs` \ stg_expr' -> -- NB: stg_expr' might still be a StgLam (and we want that) - returnUs (exprToRhs dem top_lev stg_expr') - where - dem = bdrDem bndr + returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr') \end{code} @@ -299,18 +301,13 @@ exprToRhs dem _ (StgLam _ bndrs body) constructors (ala C++ static class constructors) which will then be run at load time to fix up static closures. -} -exprToRhs dem toplev (StgCon (DataCon con) args _) +exprToRhs dem toplev (StgConApp con args) | isNotTopLevel toplev || (not is_dynamic && - all (not.is_lit_lit) args) = StgRhsCon noCCS con args + all (not . isLitLitArg) args) + = StgRhsCon noCCS con args where - is_dynamic = isDynCon con || any (isDynArg) args - - is_lit_lit (StgVarArg _) = False - is_lit_lit (StgConArg x) = - case x of - Literal l -> isLitLitLit l - _ -> False + is_dynamic = isDynDataCon con || any (isDynArg) args exprToRhs dem _ expr = upd `seq` @@ -324,22 +321,6 @@ exprToRhs dem _ expr where upd = if isOnceDem dem then SingleEntry else Updatable -- HA! Paydirt for "dem" - -isDynCon :: DataCon -> Bool -isDynCon con = isDynName (dataConName con) - -isDynArg :: StgArg -> Bool -isDynArg (StgVarArg v) = isDynName (idName v) -isDynArg (StgConArg con) = - case con of - DataCon dc -> isDynCon dc - Literal l -> isLitLitLit l - _ -> False - -isDynName :: Name -> Bool -isDynName nm = - not (isLocallyDefinedName nm) && - isDynamicModule (nameModule nm) \end{code} @@ -366,14 +347,19 @@ coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg) -- This is where we arrange that a non-trivial argument is let-bound coreArgToStg env (arg,dem) - = coreExprToStgFloat env arg dem `thenUs` \ (floats, arg') -> + = coreExprToStgFloat env arg `thenUs` \ (floats, arg') -> case arg' of - StgCon con [] _ -> returnUs (floats, StgConArg con) - StgApp v [] -> returnUs (floats, StgVarArg v) - other -> newStgVar arg_ty `thenUs` \ v -> - returnUs ([NonRecF v arg' dem floats], StgVarArg v) + StgApp v [] -> returnUs (floats, StgVarArg v) + StgLit lit -> returnUs (floats, StgLitArg lit) + + StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con)) + -- A nullary constructor can be replaced with + -- a ``call'' to its wrapper + + other -> newStgVar arg_ty `thenUs` \ v -> + returnUs ([NonRecF v arg' dem floats], StgVarArg v) where - arg_ty = coreExprType arg + arg_ty = exprType arg \end{code} @@ -384,9 +370,9 @@ coreArgToStg env (arg,dem) %************************************************************************ \begin{code} -coreExprToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgExpr -coreExprToStg env expr dem - = coreExprToStgFloat env expr dem `thenUs` \ (binds,stg_expr) -> +coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr +coreExprToStg env expr + = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) -> mkStgBinds binds stg_expr `thenUs` \ stg_expr' -> deStgLam stg_expr' \end{code} @@ -399,41 +385,40 @@ coreExprToStg env expr dem \begin{code} coreExprToStgFloat :: StgEnv -> CoreExpr - -> RhsDemand -> UniqSM ([StgFloatBind], StgExpr) --- Transform an expression to STG. The demand on the expression is --- given by RhsDemand, and is solely used ot figure out the usage --- of constructor args: if the constructor is used once, then so are --- its arguments. The strictness info in RhsDemand isn't used. - --- The StgExpr returned *can* be an StgLam +-- Transform an expression to STG. The 'floats' are +-- any bindings we had to create for function arguments. \end{code} Simple cases first \begin{code} -coreExprToStgFloat env (Var var) dem - = returnUs ([], mkStgApp (stgLookup env var) []) +coreExprToStgFloat env (Var var) + = mkStgApp env var [] (idType var) `thenUs` \ app -> + returnUs ([], app) + +coreExprToStgFloat env (Lit lit) + = returnUs ([], StgLit lit) -coreExprToStgFloat env (Let bind body) dem +coreExprToStgFloat env (Let bind body) = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) -> - coreExprToStgFloat new_env body dem `thenUs` \ (floats, stg_body) -> + coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) -> returnUs (new_bind:floats, stg_body) \end{code} Convert core @scc@ expression directly to STG @scc@ expression. \begin{code} -coreExprToStgFloat env (Note (SCC cc) expr) dem - = coreExprToStg env expr dem `thenUs` \ stg_expr -> +coreExprToStgFloat env (Note (SCC cc) expr) + = coreExprToStg env expr `thenUs` \ stg_expr -> returnUs ([], StgSCC cc stg_expr) -coreExprToStgFloat env (Note other_note expr) dem - = coreExprToStgFloat env expr dem +coreExprToStgFloat env (Note other_note expr) + = coreExprToStgFloat env expr \end{code} \begin{code} -coreExprToStgFloat env expr@(Type _) dem +coreExprToStgFloat env expr@(Type _) = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr \end{code} @@ -445,20 +430,18 @@ coreExprToStgFloat env expr@(Type _) dem %************************************************************************ \begin{code} -coreExprToStgFloat env expr@(Lam _ _) dem +coreExprToStgFloat env expr@(Lam _ _) = let - expr_ty = coreExprType expr + expr_ty = exprType expr (binders, body) = collectBinders expr id_binders = filter isId binders - body_dem = trace "coreExprToStg: approximating body_dem in Lam" - safeDem in if null id_binders then -- It was all type/usage binders; tossed - coreExprToStgFloat env body dem + coreExprToStgFloat env body else -- At least some value binders newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') -> - coreExprToStgFloat env' body body_dem `thenUs` \ (floats, stg_body) -> + coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) -> mkStgBinds floats stg_body `thenUs` \ stg_body' -> case stg_body' of @@ -479,9 +462,9 @@ coreExprToStgFloat env expr@(Lam _ _) dem %************************************************************************ \begin{code} -coreExprToStgFloat env expr@(App _ _) dem +coreExprToStgFloat env expr@(App _ _) = let - (fun,rads,_,ss) = collect_args expr + (fun,rads,ty,ss) = collect_args expr ads = reverse rads final_ads | null ss = ads | otherwise = zap ads -- Too few args to satisfy strictness info @@ -494,20 +477,21 @@ coreExprToStgFloat env expr@(App _ _) dem -- Now deal with the function case (fun, stg_args) of - (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if + (Var fn_id, _) -> -- A function Id, so do an StgApp; it's ok if -- there are no arguments. - returnUs (arg_floats, - mkStgApp (stgLookup env fun_id) stg_args) + mkStgApp env fn_id stg_args ty `thenUs` \ app -> + returnUs (arg_floats, app) (non_var_fun, []) -> -- No value args, so recurse into the function ASSERT( null arg_floats ) - coreExprToStgFloat env non_var_fun dem + coreExprToStgFloat env non_var_fun other -> -- A non-variable applied to things; better let-bind it. - newStgVar (coreExprType fun) `thenUs` \ fun_id -> - coreExprToStgFloat env fun onceDem `thenUs` \ (fun_floats, stg_fun) -> - returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats, - mkStgApp fun_id stg_args) + newStgVar (exprType fun) `thenUs` \ fn_id -> + coreExprToStgFloat env fun `thenUs` \ (fun_floats, stg_fun) -> + mkStgApp env fn_id stg_args ty `thenUs` \ app -> + returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats, + app) where -- Collect arguments and demands (*in reverse order*) @@ -540,65 +524,16 @@ coreExprToStgFloat env expr@(App _ _) dem collect_args (Var v) = (Var v, [], idType v, stricts) where - stricts = case getIdStrictness v of + stricts = case idStrictness v of StrictnessInfo demands _ -> demands other -> repeat wwLazy - collect_args fun = (fun, [], coreExprType fun, repeat wwLazy) + collect_args fun = (fun, [], exprType fun, repeat wwLazy) -- "zap" nukes the strictness info for a partial application zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads] \end{code} -%************************************************************************ -%* * -\subsubsection[coreToStg-con]{Constructors and primops} -%* * -%************************************************************************ - -For data constructors, the demand on an argument is the demand on the -constructor as a whole (see module UsageSPInf). For primops, the -demand is derived from the type of the primop. - -If usage inference is off, we simply make all bindings updatable for -speed. - -\begin{code} -coreExprToStgFloat env expr@(Con con args) dem - = let - expr_ty = coreExprType expr - (stricts,_) = conStrictness con - onces = case con of - DEFAULT -> panic "coreExprToStgFloat: DEFAULT" - - Literal _ -> ASSERT( null args' {-'cpp-} ) [] - - DataCon c -> repeat (isOnceDem dem) - -- HA! This is the sole reason we propagate - -- dem all the way down - - PrimOp p -> let tyargs = map (\ (Type ty) -> ty) $ - takeWhile isTypeArg args - (arg_tys,_) = primOpUsgTys p tyargs - in ASSERT( length arg_tys == length args' {-'cpp-} ) - -- primops always fully applied, so == not >= - map isOnceTy arg_tys - - dems' = zipWith mkDem stricts onces - args' = filter isValArg args - in - coreArgsToStg env (zip args' dems') `thenUs` \ (arg_floats, stg_atoms) -> - - -- YUK YUK: must unique if present - (case con of - PrimOp (CCallOp (Right _) a b c) -> getUniqueUs `thenUs` \ u -> - returnUs (PrimOp (CCallOp (Right u) a b c)) - _ -> returnUs con - ) `thenUs` \ con' -> - - returnUs (arg_floats, mkStgCon con' stg_atoms expr_ty) -\end{code} - %************************************************************************ %* * @@ -606,82 +541,10 @@ coreExprToStgFloat env expr@(Con con args) dem %* * %************************************************************************ -First, two special cases. We mangle cases involving - par# and seq# -inthe scrutinee. - -Up to this point, seq# will appear like this: - - case seq# e of - 0# -> seqError# - _ -> <stuff> - -This code comes from an unfolding for 'seq' in Prelude.hs. -The 0# branch is purely to bamboozle the strictness analyser. -For example, if <stuff> is strict in x, and there was no seqError# -branch, the strictness analyser would conclude that the whole expression -was strict in x, and perhaps evaluate x first -- but that would be a DISASTER. - -Now that the evaluation order is safe, we translate this into - - case e of - _ -> ... - -This used to be done in the post-simplification phase, but we need -unfoldings involving seq# to appear unmangled in the interface file, -hence we do this mangling here. - -Similarly, par# has an unfolding in PrelConc.lhs that makes it show -up like this: - - case par# e of - 0# -> rhs - _ -> parError# - - - ==> - case par# e of - _ -> rhs - -fork# isn't handled like this - it's an explicit IO operation now. -The reason is that fork# returns a ThreadId#, which gets in the -way of the above scheme. And anyway, IO is the only guaranteed -way to enforce ordering --SDM. - - \begin{code} -coreExprToStgFloat env - (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem - = coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem - where - (other_alts, maybe_default) = findDefault alts - Just default_rhs = maybe_default - new_bndr = setIdType bndr ty - -- NB: SeqOp :: forall a. a -> Int# - -- So bndr has type Int# - -- But now we are going to scrutinise the SeqOp's argument directly, - -- so we must change the type of the case binder to match that - -- of the argument expression e. We can get this type from the argument - -- type of the SeqOp. - -coreExprToStgFloat env - (Case scrut@(Con (PrimOp ParOp) args) bndr alts) dem - | maybeToBool maybe_default - = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') -> - newEvaldLocalId env bndr `thenUs` \ (env', bndr') -> - coreExprToStg env' default_rhs dem `thenUs` \ default_rhs' -> - returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr') [] (StgBindDefault default_rhs'))) - where - (other_alts, maybe_default) = findDefault alts - Just default_rhs = maybe_default -\end{code} - -Now for normal case expressions... - -\begin{code} -coreExprToStgFloat env (Case scrut bndr alts) dem - = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') -> - newEvaldLocalId env bndr `thenUs` \ (env', bndr') -> +coreExprToStgFloat env (Case scrut bndr alts) + = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') -> + newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') -> alts_to_stg env' (findDefault alts) `thenUs` \ alts' -> returnUs (binds, mkStgCase scrut' bndr' alts') where @@ -699,23 +562,23 @@ coreExprToStgFloat env (Case scrut bndr alts) dem mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' -> returnUs (mkStgAlgAlts scrut_ty alts' deflt') - alg_alt_to_stg env (DataCon con, bs, rhs) + alg_alt_to_stg env (DataAlt con, bs, rhs) = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) -> - coreExprToStg env' rhs dem `thenUs` \ stg_rhs -> + coreExprToStg env' rhs `thenUs` \ stg_rhs -> returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs) -- NB the filter isId. Some of the binders may be -- existential type variables, which STG doesn't care about - prim_alt_to_stg env (Literal lit, args, rhs) + prim_alt_to_stg env (LitAlt lit, args, rhs) = ASSERT( null args ) - coreExprToStg env rhs dem `thenUs` \ stg_rhs -> + coreExprToStg env rhs `thenUs` \ stg_rhs -> returnUs (lit, stg_rhs) default_to_stg env Nothing = returnUs StgNoDefault default_to_stg env (Just rhs) - = coreExprToStg env rhs dem `thenUs` \ stg_rhs -> + = coreExprToStg env rhs `thenUs` \ stg_rhs -> returnUs (StgBindDefault stg_rhs) -- The binder is used for prim cases and not otherwise -- (hack for old code gen) @@ -731,13 +594,6 @@ coreExprToStgFloat env (Case scrut bndr alts) dem There's not anything interesting we can ASSERT about \tr{var} if it isn't in the StgEnv. (WDP 94/06) -\begin{code} -stgLookup :: StgEnv -> Id -> Id -stgLookup env var = case (lookupVarEnv env var) of - Nothing -> var - Just var -> var -\end{code} - Invent a fresh @Id@: \begin{code} newStgVar :: Type -> UniqSM Id @@ -748,22 +604,6 @@ newStgVar ty \end{code} \begin{code} -{- Now redundant, I believe --- we overload the demandInfo field of an Id to indicate whether the Id is definitely --- evaluated or not (i.e. whether it is a case binder). This can be used to eliminate --- some redundant cases (c.f. dataToTag# above). - -newEvaldLocalId env id - = getUniqueUs `thenUs` \ uniq -> - let - id' = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq) - new_env = extendVarEnv env id id' - in - returnUs (new_env, id') --} - -newEvaldLocalId env id = newLocalId NotTopLevel env id - newLocalId TopLevel env id -- Don't clone top-level binders. MkIface relies on their -- uniques staying the same, so it can snaffle IdInfo off the @@ -809,23 +649,64 @@ newLocalIds top_lev env (b:bs) \begin{code} mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt -mkStgCon con args ty = seqType ty `seq` StgCon con args ty mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body -mkStgApp :: Id -> [StgArg] -> StgExpr -mkStgApp fn args = fn `seq` StgApp fn args - -- Force the lookup +mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr + -- The type is the type of the entire application +mkStgApp env fn args ty + = case idFlavour fn_alias of + DataConId dc + -> saturate fn_alias args ty $ \ args' ty' -> + returnUs (StgConApp dc args') + + PrimOpId (CCallOp (CCall (DynamicTarget _) a b c)) + -- Sigh...make a guaranteed unique name for a dynamic ccall + -> saturate fn_alias args ty $ \ args' ty' -> + getUniqueUs `thenUs` \ u -> + returnUs (StgPrimApp (CCallOp (CCall (DynamicTarget u) a b c)) args' ty') + + PrimOpId op + -> saturate fn_alias args ty $ \ args' ty' -> + returnUs (StgPrimApp op args' ty') + + other -> returnUs (StgApp fn_alias args) + -- Force the lookup + where + fn_alias = case (lookupVarEnv env fn) of -- In case it's been cloned + Nothing -> fn + Just fn' -> fn' + +saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr +saturate fn args ty thing_inside + | excess_arity == 0 -- Saturated, so nothing to do + = thing_inside args ty + + | otherwise -- An unsaturated constructor or primop; eta expand it + = ASSERT2( excess_arity > 0 && excess_arity <= length extra_arg_tys, + ppr fn <+> ppr args <+> ppr excess_arity ) + mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars -> + thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body -> + returnUs (StgLam ty arg_vars body) + where + fn_arity = idArity fn + excess_arity = fn_arity - length args + (arg_tys, res_ty) = splitRepFunTys ty + extra_arg_tys = take excess_arity arg_tys + final_res_ty = mkFunTys (drop excess_arity arg_tys) res_ty \end{code} \begin{code} --- Stg doesn't have a lambda *expression*, -deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body -deStgLam expr = returnUs expr - -mkStgLamExpr ty bndrs body +-- Stg doesn't have a lambda *expression* +deStgLam (StgLam ty bndrs body) + -- Try for eta reduction = ASSERT( not (null bndrs) ) - newStgVar ty `thenUs` \ fn -> - returnUs (StgLet (StgNonRec fn lam_closure) (mkStgApp fn [])) + case eta body of + Just e -> -- Eta succeeded + returnUs e + + Nothing -> -- Eta failed, so let-bind the lambda + newStgVar ty `thenUs` \ fn -> + returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn [])) where lam_closure = StgRhsClosure noCCS stgArgOcc @@ -835,6 +716,52 @@ mkStgLamExpr ty bndrs body bndrs body + eta (StgApp f args) + | n_remaining >= 0 && + and (zipWith ok bndrs last_args) && + notInExpr bndrs remaining_expr + = Just remaining_expr + where + remaining_expr = StgApp f remaining_args + (remaining_args, last_args) = splitAt n_remaining args + n_remaining = length args - length bndrs + + eta (StgLet bind@(StgNonRec b r) body) + | notInRhs bndrs r = case eta body of + Just e -> Just (StgLet bind e) + Nothing -> Nothing + + eta _ = Nothing + + ok bndr (StgVarArg arg) = bndr == arg + ok bndr other = False + +deStgLam expr = returnUs expr + + +-------------------------------------------------- +notInExpr :: [Id] -> StgExpr -> Bool +notInExpr vs (StgApp f args) = notInId vs f && notInArgs vs args +notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body +notInExpr vs other = False -- Safe + +notInRhs :: [Id] -> StgRhs -> Bool +notInRhs vs (StgRhsCon _ _ args) = notInArgs vs args +notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body + -- Conservative: we could delete the binders from vs, but + -- cloning means this will never help + +notInArgs :: [Id] -> [StgArg] -> Bool +notInArgs vs args = all ok args + where + ok (StgVarArg v) = notInId vs v + ok (StgLitArg l) = True + +notInId :: [Id] -> Id -> Bool +notInId vs v = not (v `elem` vs) + + + mkStgBinds :: [StgFloatBind] -> StgExpr -- *Can* be a StgLam -> UniqSM StgExpr -- *Can* be a StgLam @@ -895,9 +822,9 @@ mk_stg_let bndr rhs dem floats body bndr_rep_ty = repType (idType bndr) is_strict = isStrictDem dem is_whnf = case rhs of - StgCon _ _ _ -> True - StgLam _ _ _ -> True - other -> False + StgConApp _ _ -> True + StgLam _ _ _ -> True + other -> False -- Split at the first strict binding splitFloats fs@(NonRecF _ _ dem _ : _) @@ -907,7 +834,80 @@ splitFloats (f : fs) = case splitFloats fs of (fs_out, fs_in) -> (f : fs_out, fs_in) splitFloats [] = ([], []) +\end{code} + + +Making an STG case +~~~~~~~~~~~~~~~~~~ + +First, two special cases. We mangle cases involving + par# and seq# +inthe scrutinee. + +Up to this point, seq# will appear like this: + + case seq# e of + 0# -> seqError# + _ -> <stuff> + +This code comes from an unfolding for 'seq' in Prelude.hs. +The 0# branch is purely to bamboozle the strictness analyser. +For example, if <stuff> is strict in x, and there was no seqError# +branch, the strictness analyser would conclude that the whole expression +was strict in x, and perhaps evaluate x first -- but that would be a DISASTER. + +Now that the evaluation order is safe, we translate this into + + case e of + _ -> ... + +This used to be done in the post-simplification phase, but we need +unfoldings involving seq# to appear unmangled in the interface file, +hence we do this mangling here. + +Similarly, par# has an unfolding in PrelConc.lhs that makes it show +up like this: + + case par# e of + 0# -> rhs + _ -> parError# + + + ==> + case par# e of + _ -> rhs + +fork# isn't handled like this - it's an explicit IO operation now. +The reason is that fork# returns a ThreadId#, which gets in the +way of the above scheme. And anyway, IO is the only guaranteed +way to enforce ordering --SDM. + + +\begin{code} +-- Discard alernatives in case (par# ..) of +mkStgCase scrut@(StgPrimApp ParOp _ _) bndr + (StgPrimAlts ty _ deflt@(StgBindDefault _)) + = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt) + +mkStgCase (StgPrimApp SeqOp [scrut] _) bndr + (StgPrimAlts _ _ deflt@(StgBindDefault rhs)) + = mkStgCase scrut_expr new_bndr (StgAlgAlts scrut_ty [] (StgBindDefault rhs)) + where + new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt + | otherwise = StgAlgAlts scrut_ty [] deflt + scrut_ty = stgArgType scrut + new_bndr = setIdType bndr scrut_ty + -- NB: SeqOp :: forall a. a -> Int# + -- So bndr has type Int# + -- But now we are going to scrutinise the SeqOp's argument directly, + -- so we must change the type of the case binder to match that + -- of the argument expression e. + scrut_expr = case scrut of + StgVarArg v -> StgApp v [] + -- Others should not happen because + -- seq of a value should have disappeared + StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l mkStgCase scrut bndr alts = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } ) diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 11ca9448dc..c0300a5cf7 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -13,8 +13,9 @@ import StgSyn import Bag ( Bag, emptyBag, isEmptyBag, snocBag, foldBag ) import Id ( Id, idType ) import VarSet -import DataCon ( DataCon, dataConArgTys, dataConType ) -import Const ( literalType, conType, Literal ) +import DataCon ( DataCon, dataConArgTys, dataConRepType ) +import PrimOp ( primOpType ) +import Literal ( literalType, Literal ) import Maybes ( catMaybes ) import Name ( isLocallyDefined, getSrcLoc ) import ErrUtils ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc ) @@ -67,7 +68,7 @@ lintStgBindings whodunnit binds \begin{code} lintStgArg :: StgArg -> LintM (Maybe Type) -lintStgArg (StgConArg con) = returnL (Just (conType con)) +lintStgArg (StgLitArg lit) = returnL (Just (literalType lit)) lintStgArg (StgVarArg v) = lintStgVar v lintStgVar v = checkInScope v `thenL_` @@ -130,12 +131,14 @@ lintStgRhs (StgRhsCon _ con args) Nothing -> returnL Nothing Just arg_tys -> checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys) where - con_ty = dataConType con + con_ty = dataConRepType con \end{code} \begin{code} lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Nothing if error found +lintStgExpr (StgLit l) = returnL (Just (literalType l)) + lintStgExpr e@(StgApp fun args) = lintStgVar fun `thenMaybeL` \ fun_ty -> mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys -> @@ -143,13 +146,21 @@ lintStgExpr e@(StgApp fun args) Nothing -> returnL Nothing Just arg_tys -> checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e) -lintStgExpr e@(StgCon con args _) +lintStgExpr e@(StgConApp con args) = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys -> case maybe_arg_tys of Nothing -> returnL Nothing Just arg_tys -> checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e) where - con_ty = conType con + con_ty = dataConRepType con + +lintStgExpr e@(StgPrimApp op args _) + = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys -> + case maybe_arg_tys of + Nothing -> returnL Nothing + Just arg_tys -> checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e) + where + op_ty = primOpType op lintStgExpr (StgLam _ bndrs _) = addErrL (ptext SLIT("Unexpected StgLam") <+> ppr bndrs) `thenL_` @@ -178,8 +189,8 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts) (trace (showSDoc (ppr e)) $ -- we only allow case of tail-call or primop. (case scrut of - StgApp _ _ -> returnL () - StgCon _ _ _ -> returnL () + StgApp _ _ -> returnL () + StgConApp _ _ -> returnL () other -> addErrL (mkCaseOfCaseMsg e)) `thenL_` addInScopeVars [bndr] (lintStgAlts alts scrut_ty) diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 1c10d34923..759c174f09 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -33,8 +33,8 @@ module StgSyn ( pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, getArgPrimRep, - isLitLitArg, - stgArity, + isLitLitArg, isDynArg, isStgTypeArg, + stgArity, stgArgType, collectFinalStgBinders #ifdef DEBUG @@ -45,9 +45,11 @@ module StgSyn ( #include "HsVersions.h" import CostCentre ( CostCentreStack, CostCentre ) -import Id ( idPrimRep, Id ) -import Const ( Con(..), DataCon, Literal, - conPrimRep, isLitLitLit ) +import Id ( Id, idName, idPrimRep, idType ) +import Name ( isDynName ) +import Literal ( Literal, literalType, isLitLitLit, literalPrimRep ) +import DataCon ( DataCon, isDynDataCon, isNullaryDataCon ) +import PrimOp ( PrimOp ) import PrimRep ( PrimRep(..) ) import Outputable import Type ( Type ) @@ -80,15 +82,29 @@ data GenStgBinding bndr occ \begin{code} data GenStgArg occ = StgVarArg occ - | StgConArg Con -- A literal or nullary data constructor + | StgLitArg Literal + | StgTypeArg Type -- For when we want to preserve all type info \end{code} \begin{code} -getArgPrimRep (StgVarArg local) = idPrimRep local -getArgPrimRep (StgConArg con) = conPrimRep con +getArgPrimRep (StgVarArg local) = idPrimRep local +getArgPrimRep (StgLitArg lit) = literalPrimRep lit -isLitLitArg (StgConArg (Literal x)) = isLitLitLit x -isLitLitArg _ = False +isLitLitArg (StgLitArg lit) = isLitLitLit lit +isLitLitArg _ = False + +isStgTypeArg (StgTypeArg _) = True +isStgTypeArg other = False + +isDynArg :: StgArg -> Bool + -- Does this argument refer to something in a DLL? +isDynArg (StgVarArg v) = isDynName (idName v) +isDynArg (StgLitArg lit) = isLitLitLit lit + +stgArgType :: StgArg -> Type + -- Very half baked becase we have lost the type arguments +stgArgType (StgVarArg v) = idType v +stgArgType (StgLitArg lit) = literalType lit \end{code} %************************************************************************ @@ -119,31 +135,28 @@ type GenStgLiveVars occ = UniqSet occ data GenStgExpr bndr occ = StgApp occ -- function - [GenStgArg occ] -- arguments - - -- NB: a literal is: StgApp <lit-atom> [] ... + [GenStgArg occ] -- arguments; may be empty \end{code} %************************************************************************ %* * -\subsubsection{@StgCon@ and @StgPrim@---saturated applications} +\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications} %* * %************************************************************************ There are a specialised forms of application, for constructors, primitives, and literals. \begin{code} - | StgCon -- always saturated - Con - [GenStgArg occ] - - Type -- Result type; this is needed for primops, where - -- we need to know the result type so that we can - -- assign result registers. - + | StgLit Literal + + | StgConApp DataCon + [GenStgArg occ] -- Saturated + + | StgPrimApp PrimOp + [GenStgArg occ] -- Saturated + Type -- Result type; we need to know the result type + -- so that we can assign result registers. \end{code} -These forms are to do ``inline versions,'' as it were. -An example might be: @f x = x:[]@. %************************************************************************ %* * @@ -586,14 +599,15 @@ instance (Outputable bndr, Outputable bdee, Ord bdee) pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc pprStgArg (StgVarArg var) = ppr var -pprStgArg (StgConArg con) = ppr con +pprStgArg (StgLitArg con) = ppr con +pprStgARg (StgTypeArg ty) = char '@' <+> ppr ty \end{code} \begin{code} pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) => GenStgExpr bndr bdee -> SDoc -- special case -pprStgExpr (StgApp func []) = ppr func +pprStgExpr (StgLit lit) = ppr lit -- general case pprStgExpr (StgApp func args) @@ -602,9 +616,12 @@ pprStgExpr (StgApp func args) \end{code} \begin{code} -pprStgExpr (StgCon con args _) +pprStgExpr (StgConApp con args) = hsep [ ppr con, brackets (interppSP args)] +pprStgExpr (StgPrimApp op args _) + = hsep [ ppr op, brackets (interppSP args)] + pprStgExpr (StgLam _ bndrs body) =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"), pprStgExpr body ] diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index aa08205721..3c7dfb5d52 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -18,16 +18,14 @@ module SaAbsInt ( import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict ) import CoreSyn import CoreUnfold ( Unfolding, maybeUnfoldingTemplate ) -import PrimOp ( primOpStrictness ) -import Id ( Id, idType, getIdStrictness, getIdUnfolding ) -import Const ( Con(..) ) -import DataCon ( dataConTyCon, splitProductType_maybe ) +import Id ( Id, idType, idArity, idStrictness, idUnfolding, isDataConId_maybe ) +import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys ) import IdInfo ( StrictnessInfo(..) ) -import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, +import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwLazy, wwUnpackNew ) import SaLib -import TyCon ( isProductTyCon, isEnumerationTyCon, isNewTyCon ) -import BasicTypes ( NewOrData(..) ) +import TyCon ( isProductTyCon, isRecursiveTyCon, isEnumerationTyCon, isNewTyCon ) +import BasicTypes ( Arity, NewOrData(..) ) import Type ( splitAlgTyConApp_maybe, isUnLiftedType, Type ) import TyCon ( tyConUnique ) @@ -47,10 +45,8 @@ Least upper bound, greatest lower bound. \begin{code} lub, glb :: AbsVal -> AbsVal -> AbsVal -lub val1 val2 | isBot val1 = val2 -- The isBot test includes the case where -lub val1 val2 | isBot val2 = val1 -- one of the val's is a function which - -- always returns bottom, such as \y.x, - -- when x is bound to bottom. +lub AbsBot val2 = val2 +lub val1 AbsBot = val1 lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys) @@ -102,7 +98,7 @@ glb v1 v2 else AbsBot where - is_fun (AbsFun _ _ _) = True + is_fun (AbsFun _ _) = True is_fun (AbsApproxFun _ _) = True -- Not used, but the glb works ok is_fun other = False @@ -127,18 +123,18 @@ isBot :: AbsVal -> Bool isBot AbsBot = True isBot other = False -- Functions aren't bottom any more - \end{code} Used only in absence analysis: + \begin{code} anyBot :: AbsVal -> Bool -anyBot AbsBot = True -- poisoned! -anyBot AbsTop = False -anyBot (AbsProd vals) = any anyBot vals -anyBot (AbsFun bndr body env) = anyBot (absEval AbsAnal body (addOneToAbsValEnv env bndr AbsTop)) -anyBot (AbsApproxFun _ val) = anyBot val +anyBot AbsBot = True -- poisoned! +anyBot AbsTop = False +anyBot (AbsProd vals) = any anyBot vals +anyBot (AbsFun bndr_ty abs_fn) = anyBot (abs_fn AbsTop) +anyBot (AbsApproxFun _ val) = anyBot val \end{code} @widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is @@ -149,22 +145,21 @@ it, so it can be compared for equality by @sameVal@. widen :: AnalysisKind -> AbsVal -> AbsVal -- Widening is complicated by the fact that funtions are lifted -widen StrAnal the_fn@(AbsFun bndr body env) +widen StrAnal the_fn@(AbsFun bndr_ty _) = case widened_body of AbsApproxFun ds val -> AbsApproxFun (d : ds) val where d = findRecDemand str_fn abs_fn bndr_ty - str_fn val = foldl (absApply StrAnal) the_fn - (val : [AbsTop | d <- ds]) + str_fn val = isBot (foldl (absApply StrAnal) the_fn + (val : [AbsTop | d <- ds])) other -> AbsApproxFun [d] widened_body where d = findRecDemand str_fn abs_fn bndr_ty - str_fn val = absApply StrAnal the_fn val + str_fn val = isBot (absApply StrAnal the_fn val) where - bndr_ty = idType bndr widened_body = widen StrAnal (absApply StrAnal the_fn AbsTop) - abs_fn val = AbsBot -- Always says poison; so it looks as if + abs_fn val = False -- Always says poison; so it looks as if -- nothing is absent; safe {- OLD comment... @@ -193,7 +188,7 @@ widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals) widen StrAnal other_val = other_val -widen AbsAnal the_fn@(AbsFun bndr body env) +widen AbsAnal the_fn@(AbsFun bndr_ty _) | anyBot widened_body = AbsBot -- In the absence-analysis case it's *essential* to check -- that the function has no poison in its body. If it does, @@ -204,17 +199,16 @@ widen AbsAnal the_fn@(AbsFun bndr body env) AbsApproxFun ds val -> AbsApproxFun (d : ds) val where d = findRecDemand str_fn abs_fn bndr_ty - abs_fn val = foldl (absApply AbsAnal) the_fn - (val : [AbsTop | d <- ds]) + abs_fn val = not (anyBot (foldl (absApply AbsAnal) the_fn + (val : [AbsTop | d <- ds]))) other -> AbsApproxFun [d] widened_body where d = findRecDemand str_fn abs_fn bndr_ty - abs_fn val = absApply AbsAnal the_fn val + abs_fn val = not (anyBot (absApply AbsAnal the_fn val)) where - bndr_ty = idType bndr widened_body = widen AbsAnal (absApply AbsAnal the_fn AbsTop) - str_fn val = AbsBot -- Always says non-termination; + str_fn val = True -- Always says non-termination; -- that'll make findRecDemand peer into the -- structure of the value. @@ -254,8 +248,8 @@ crudeAbsWiden val = if anyBot val then AbsBot else AbsTop sameVal :: AbsVal -> AbsVal -> Bool -- Can't handle AbsFun! #ifdef DEBUG -sameVal (AbsFun _ _ _) _ = panic "sameVal: AbsFun: arg1" -sameVal _ (AbsFun _ _ _) = panic "sameVal: AbsFun: arg2" +sameVal (AbsFun _ _) _ = panic "sameVal: AbsFun: arg1" +sameVal _ (AbsFun _ _) = panic "sameVal: AbsFun: arg2" #endif sameVal AbsBot AbsBot = True @@ -348,12 +342,25 @@ evalAbsence other val = anyBot val -- error's arg absId anal var env - = case (lookupAbsValEnv env var, getIdStrictness var, maybeUnfoldingTemplate (getIdUnfolding var)) of + = case (lookupAbsValEnv env var, + isDataConId_maybe var, + idStrictness var, + maybeUnfoldingTemplate (idUnfolding var)) of - (Just abs_val, _, _) -> + (Just abs_val, _, _, _) -> abs_val -- Bound in the environment - (Nothing, NoStrictnessInfo, Just unfolding) -> + (_, Just data_con, _, _) | isProductTyCon tycon && + not (isRecursiveTyCon tycon) + -> -- A product. We get infinite loops if we don't + -- check for recursive products! + -- The strictness info on the constructor + -- isn't expressive enough to contain its abstract value + productAbsVal (dataConRepArgTys data_con) [] + where + tycon = dataConTyCon data_con + + (_, _, NoStrictnessInfo, Just unfolding) -> -- We have an unfolding for the expr -- Assume the unfolding has no free variables since it -- came from inside the Id @@ -378,10 +385,13 @@ absId anal var env -- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-} - (Nothing, strictness_info, _) -> + (_, _, strictness_info, _) -> -- Includes NoUnfolding -- Try the strictness info absValFromStrictness anal strictness_info + +productAbsVal [] rev_abs_args = AbsProd (reverse rev_abs_args) +productAbsVal (arg_ty : arg_tys) rev_abs_args = AbsFun arg_ty (\ abs_arg -> productAbsVal arg_tys (abs_arg : rev_abs_args)) \end{code} \begin{code} @@ -413,45 +423,16 @@ Things are a little different for absence analysis, because we want to make sure that any poison (?????) \begin{code} -absEval anal (Con (Literal _) args) env - = -- Literals terminate (strictness) and are not poison (absence) - AbsTop - -absEval anal (Con (PrimOp op) args) env - = -- Not all PrimOps evaluate all their arguments - if or (zipWith (check_arg anal) - [absEval anal arg env | arg <- args, isValArg arg] - arg_demands) - then AbsBot - else case anal of - StrAnal | result_bot -> AbsBot - other -> AbsTop - where - (arg_demands, result_bot) = primOpStrictness op - check_arg StrAnal arg dmd = evalStrictness dmd arg - check_arg AbsAnal arg dmd = evalAbsence dmd arg - -absEval anal (Con (DataCon con) args) env - | isProductTyCon (dataConTyCon con) - = -- Products; filter out type arguments - AbsProd [absEval anal a env | a <- args, isValArg a] - - | otherwise -- Not single-constructor - = case anal of - StrAnal -> -- Strictness case: it's easy: it certainly terminates - AbsTop - AbsAnal -> -- In the absence case we need to be more - -- careful: look to see if there's any - -- poison in the components - if any anyBot [absEval AbsAnal arg env | arg <- args] - then AbsBot - else AbsTop +absEval anal (Lit _) env = AbsTop + -- Literals terminate (strictness) and are not poison (absence) \end{code} \begin{code} absEval anal (Lam bndr body) env | isTyVar bndr = absEval anal body env -- Type lambda - | otherwise = AbsFun bndr body env -- Value lambda + | otherwise = AbsFun (idType bndr) abs_fn -- Value lambda + where + abs_fn arg = absEval anal body (addOneToAbsValEnv env bndr arg) absEval anal (App expr (Type ty)) env = absEval anal expr env -- Type appplication @@ -570,8 +551,7 @@ result. A @Lam@ with two or more args: return another @AbsFun@ with an augmented environment. \begin{code} -absApply anal (AbsFun binder body env) arg - = absEval anal body (addOneToAbsValEnv env binder arg) +absApply anal (AbsFun bndr_ty abs_fn) arg = abs_fn arg \end{code} \begin{code} @@ -604,59 +584,64 @@ absApply anal f@(AbsProd _) arg = pprPanic ("absApply: Duff function: AbsP %* * %************************************************************************ -@findStrictness@ applies the function \tr{\ ids -> expr} to -\tr{[bot,top,top,...]}, \tr{[top,bot,top,top,...]}, etc., (i.e., once -with @AbsBot@ in each argument position), and evaluates the resulting -abstract value; it returns a vector of @Demand@s saying whether the -result of doing this is guaranteed to be bottom. This tells the -strictness of the function in each of the arguments. - -If an argument is of unboxed type, then we declare that function to be -strict in that argument. - -We don't really have to make up all those lists of mostly-@AbsTops@; -unbound variables in an @AbsValEnv@ are implicitly mapped to that. - -See notes on @addStrictnessInfoToId@. - \begin{code} -findStrictness :: [Type] -- Types of args in which strictness is wanted +findStrictness :: Id -> AbsVal -- Abstract strictness value of function -> AbsVal -- Abstract absence value of function - -> ([Demand], Bool) -- Resulting strictness annotation - -findStrictness tys str_val abs_val - = (map find_str tys_w_index, isBot (foldl (absApply StrAnal) str_val all_tops)) - where - tys_w_index = tys `zip` [(1::Int) ..] + -> StrictnessInfo -- Resulting strictness annotation + +findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _) + -- You might think there's really no point in describing detailed + -- strictness for a divergent function; + -- If it's fully applied we get bottom regardless of the + -- argument. If it's not fully applied we don't get bottom. + -- Finally, we don't want to regard the args of a divergent function + -- as 'interesting' for inlining purposes (see Simplify.prepareArgs) + -- + -- HOWEVER, if we make diverging functions appear lazy, they + -- don't get wrappers, and then we get dreadful reboxing. + -- See notes with WwLib.worthSplitting + = StrictnessInfo (combineDemands id str_ds abs_ds) (isBot str_res) - find_str (ty,n) = findRecDemand str_fn abs_fn ty - where - str_fn val = foldl (absApply StrAnal) str_val - (map (mk_arg val n) tys_w_index) +findStrictness id str_val abs_val = NoStrictnessInfo - abs_fn val = foldl (absApply AbsAnal) abs_val - (map (mk_arg val n) tys_w_index) +-- The list of absence demands passed to combineDemands +-- can be shorter than the list of absence demands +-- +-- lookup = \ dEq -> letrec { +-- lookup = \ key ds -> ...lookup... +-- } +-- in lookup +-- Here the strictness value takes three args, but the absence value +-- takes only one, for reasons I don't quite understand (see cheapFixpoint) + +combineDemands id orig_str_ds orig_abs_ds + = go orig_str_ds orig_abs_ds + where + go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy) - mk_arg val n (_,m) | m==n = val - | otherwise = AbsTop + mk_dmd str_dmd (WwLazy True) = WARN( case str_dmd of { WwLazy _ -> False; other -> True }, + ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds ) + WwLazy True -- Best of all + mk_dmd (WwUnpack nd u str_ds) + (WwUnpack _ _ abs_ds) = WwUnpack nd u (go str_ds abs_ds) - all_tops = [AbsTop | _ <- tys] + mk_dmd str_dmd abs_dmd = str_dmd \end{code} \begin{code} -findDemand str_env abs_env expr binder +findDemand dmd str_env abs_env expr binder = findRecDemand str_fn abs_fn (idType binder) where - str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val) - abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val) + str_fn val = evalStrictness dmd (absEval StrAnal expr (addOneToAbsValEnv str_env binder val)) + abs_fn val = not (evalAbsence dmd (absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val))) -findDemandAlts str_env abs_env alts binder +findDemandAlts dmd str_env abs_env alts binder = findRecDemand str_fn abs_fn (idType binder) where - str_fn val = absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val) - abs_fn val = absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val) + str_fn val = evalStrictness dmd (absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val)) + abs_fn val = not (evalAbsence dmd (absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val))) \end{code} @findRecDemand@ is where we finally convert strictness/absence info @@ -692,8 +677,8 @@ then we'd let-to-case it: Ho hum. \begin{code} -findRecDemand :: (AbsVal -> AbsVal) -- The strictness function - -> (AbsVal -> AbsVal) -- The absence function +findRecDemand :: (AbsVal -> Bool) -- True => function applied to this value yields Bot + -> (AbsVal -> Bool) -- True => function applied to this value yields no poison -> Type -- The type of the argument -> Demand @@ -701,13 +686,13 @@ findRecDemand str_fn abs_fn ty = if isUnLiftedType ty then -- It's a primitive type! wwPrim - else if not (anyBot (abs_fn AbsBot)) then -- It's absent + else if abs_fn AbsBot then -- It's absent -- We prefer absence over strictness: see NOTE above. WwLazy True else if not (opt_AllStrict || - (opt_NumbersStrict && is_numeric_type ty) || - (isBot (str_fn AbsBot))) then + (opt_NumbersStrict && is_numeric_type ty) || + str_fn AbsBot) then WwLazy False -- It's not strict and we're not pretending else -- It's strict (or we're pretending it is)! @@ -717,7 +702,7 @@ findRecDemand str_fn abs_fn ty Nothing -> wwStrict -- Could have a test for wwEnum, but -- we don't exploit it yet, so don't bother - Just (tycon,_,data_con,cmpnt_tys) -- Non-recursive, single constructor case + Just (tycon,_,data_con,cmpnt_tys) -- Single constructor case | isNewTyCon tycon -- A newtype! -> ASSERT( null (tail cmpnt_tys) ) let @@ -725,7 +710,8 @@ findRecDemand str_fn abs_fn ty in wwUnpackNew demand - | null compt_strict_infos -- A nullary data type + | null compt_strict_infos -- A nullary data type + || isRecursiveTyCon tycon -- Recursive data type; don't unpack -> wwStrict | otherwise -- Some other data type diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index 1a057b6081..813410ce33 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -19,6 +19,7 @@ module SaLib ( #include "HsVersions.h" import Id ( Id ) +import Type ( Type ) import CoreSyn ( CoreExpr ) import VarEnv import IdInfo ( StrictnessInfo(..) ) @@ -58,9 +59,8 @@ data AbsVal -- AbsProd [AbsBot, ..., AbsBot] | AbsFun -- An abstract function, with the given: - Id -- argument - CoreExpr -- body - AbsValEnv -- and environment + Type -- Type of the *argument* to the function + (AbsVal -> AbsVal) -- The function | AbsApproxFun -- This is used to represent a coarse [Demand] -- approximation to a function value. It's an @@ -81,12 +81,9 @@ instance Outputable AbsVal where ppr AbsTop = ptext SLIT("AbsTop") ppr AbsBot = ptext SLIT("AbsBot") ppr (AbsProd prod) = hsep [ptext SLIT("AbsProd"), ppr prod] - ppr (AbsFun arg body env) - = hsep [ptext SLIT("AbsFun{"), ppr arg, - ptext SLIT("???"), -- text "}{env:", ppr (keysFM env `zip` eltsFM env), - char '}' ] + ppr (AbsFun bndr_ty body) = ptext SLIT("AbsFun") ppr (AbsApproxFun demands val) - = hsep [ptext SLIT("AbsApprox "), hcat (map ppr demands), ppr val] + = ptext SLIT("AbsApprox") <+> brackets (interpp'SP demands) <+> ppr val \end{code} %----------- diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 081e039885..a4490cf4ac 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -13,19 +13,19 @@ module StrictAnal ( saBinds ) where import CmdLineOpts ( opt_D_dump_stranal, opt_D_dump_simpl_stats, opt_D_verbose_core2core ) import CoreSyn -import Id ( idType, setIdStrictness, - getIdDemandInfo, setIdDemandInfo, +import Id ( idType, setIdStrictness, setInlinePragma, + idDemandInfo, setIdDemandInfo, isBottomingId, Id ) -import IdInfo ( mkStrictnessInfo ) +import IdInfo ( InlinePragInfo(..) ) import CoreLint ( beginPass, endPass ) -import Type ( repType, splitFunTys ) +import Type ( splitRepFunTys ) import ErrUtils ( dumpIfSet ) import SaAbsInt import SaLib -import Demand ( isStrict ) +import Demand ( Demand, wwStrict, isStrict, isLazy ) import UniqSupply ( UniqSupply ) -import Util ( zipWith4Equal ) +import Util ( zipWith3Equal, stretchZipWith ) import Outputable \end{code} @@ -148,7 +148,7 @@ saTopBind :: StrictEnv -> AbsenceEnv -> SaM (StrictEnv, AbsenceEnv, CoreBind) saTopBind str_env abs_env (NonRec binder rhs) - = saExpr str_env abs_env rhs `thenSa` \ new_rhs -> + = saExpr minDemand str_env abs_env rhs `thenSa` \ new_rhs -> let str_rhs = absEval StrAnal rhs str_env abs_rhs = absEval AbsAnal rhs abs_env @@ -159,10 +159,9 @@ saTopBind str_env abs_env (NonRec binder rhs) -- See notes on Let case in SaAbsInt.lhs new_binder - = addStrictnessInfoToId + = addStrictnessInfoToTopId widened_str_rhs widened_abs_rhs binder - rhs -- Augment environments with a mapping of the -- binder to its abstract values, computed by absEval @@ -179,14 +178,25 @@ saTopBind str_env abs_env (Rec pairs) -- fixpoint returns widened values new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss) new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss) - new_binders = zipWith4Equal "saTopBind" addStrictnessInfoToId - str_rhss abs_rhss binders rhss + new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId + str_rhss abs_rhss binders in - mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> + mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> let new_pairs = new_binders `zip` new_rhss in returnSa (new_str_env, new_abs_env, Rec new_pairs) + +-- Top level divergent bindings are marked NOINLINE +-- This avoids fruitless inlining of top level error functions +addStrictnessInfoToTopId str_val abs_val bndr + = if isBottomingId new_id then + new_id `setInlinePragma` IMustNotBeINLINEd False Nothing + -- This is a NOINLINE pragma + else + new_id + where + new_id = addStrictnessInfoToId str_val abs_val bndr \end{code} %************************************************************************ @@ -199,49 +209,84 @@ saTopBind str_env abs_env (Rec pairs) environment. \begin{code} -saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr - -saExpr _ _ e@(Var _) = returnSa e -saExpr _ _ e@(Con _ _) = returnSa e -saExpr _ _ e@(Type _) = returnSa e - -saExpr str_env abs_env (Lam bndr body) +saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr + -- The demand is the least demand we expect on the + -- expression. WwStrict is the least, because we're only + -- interested in the expression at all if it's being evaluated, + -- but the demand may be more. E.g. + -- f E + -- where f has strictness u(LL), will evaluate E with demand u(LL) + +minDemand = wwStrict +minDemands = repeat minDemand + +-- When we find an application, do the arguments +-- with demands gotten from the function +saApp str_env abs_env (fun, args) + = sequenceSa sa_args `thenSa` \ args' -> + saExpr minDemand str_env abs_env fun `thenSa` \ fun' -> + returnSa (mkApps fun' args') + where + arg_dmds = case fun of + Var var -> case lookupAbsValEnv str_env var of + Just (AbsApproxFun ds _) | length ds >= length args + -> ds ++ minDemands + other -> minDemands + other -> minDemands + + sa_args = stretchZipWith isTypeArg (error "saApp:dmd") + sa_arg args arg_dmds + -- The arg_dmds are for value args only, we need to skip + -- over the type args when pairing up with the demands + -- Hence the stretchZipWith + + sa_arg arg dmd = saExpr dmd' str_env abs_env arg + where + -- Bring arg demand up to minDemand + dmd' | isLazy dmd = minDemand + | otherwise = dmd + +saExpr _ _ _ e@(Var _) = returnSa e +saExpr _ _ _ e@(Lit _) = returnSa e +saExpr _ _ _ e@(Type _) = returnSa e + +saExpr dmd str_env abs_env (Lam bndr body) = -- Don't bother to set the demand-info on a lambda binder -- We do that only for let(rec)-bound functions - saExpr str_env abs_env body `thenSa` \ new_body -> + saExpr minDemand str_env abs_env body `thenSa` \ new_body -> returnSa (Lam bndr new_body) -saExpr str_env abs_env (App fun arg) - = saExpr str_env abs_env fun `thenSa` \ new_fun -> - saExpr str_env abs_env arg `thenSa` \ new_arg -> - returnSa (App new_fun new_arg) +saExpr dmd str_env abs_env e@(App fun arg) + = saApp str_env abs_env (collectArgs e) -saExpr str_env abs_env (Note note expr) - = saExpr str_env abs_env expr `thenSa` \ new_expr -> +saExpr dmd str_env abs_env (Note note expr) + = saExpr dmd str_env abs_env expr `thenSa` \ new_expr -> returnSa (Note note new_expr) -saExpr str_env abs_env (Case expr case_bndr alts) - = saExpr str_env abs_env expr `thenSa` \ new_expr -> - mapSa sa_alt alts `thenSa` \ new_alts -> +saExpr dmd str_env abs_env (Case expr case_bndr alts) + = saExpr minDemand str_env abs_env expr `thenSa` \ new_expr -> + mapSa sa_alt alts `thenSa` \ new_alts -> let - new_case_bndr = addDemandInfoToCaseBndr str_env abs_env alts case_bndr + new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr in returnSa (Case new_expr new_case_bndr new_alts) where sa_alt (con, binders, rhs) - = saExpr str_env abs_env rhs `thenSa` \ new_rhs -> + = saExpr dmd str_env abs_env rhs `thenSa` \ new_rhs -> let new_binders = map add_demand_info binders add_demand_info bndr | isTyVar bndr = bndr - | otherwise = addDemandInfoToId str_env abs_env rhs bndr + | otherwise = addDemandInfoToId dmd str_env abs_env rhs bndr in tickCases new_binders `thenSa_` -- stats returnSa (con, new_binders, new_rhs) -saExpr str_env abs_env (Let (NonRec binder rhs) body) +saExpr dmd str_env abs_env (Let (NonRec binder rhs) body) = -- Analyse the RHS in the environment at hand - saExpr str_env abs_env rhs `thenSa` \ new_rhs -> let + -- Find the demand on the RHS + rhs_dmd = findDemand dmd str_env abs_env body binder + -- Bind this binder to the abstract value of the RHS; analyse -- the body of the `let' in the extended environment. str_rhs_val = absEval StrAnal rhs str_env @@ -259,14 +304,14 @@ saExpr str_env abs_env (Let (NonRec binder rhs) body) -- to record DemandInfo/StrictnessInfo in the binder. new_binder = addStrictnessInfoToId widened_str_rhs widened_abs_rhs - (addDemandInfoToId str_env abs_env body binder) - rhs + (binder `setIdDemandInfo` rhs_dmd) in - tickLet new_binder `thenSa_` -- stats - saExpr new_str_env new_abs_env body `thenSa` \ new_body -> + tickLet new_binder `thenSa_` -- stats + saExpr rhs_dmd str_env abs_env rhs `thenSa` \ new_rhs -> + saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body -> returnSa (Let (NonRec new_binder new_rhs) new_body) -saExpr str_env abs_env (Let (Rec pairs) body) +saExpr dmd str_env abs_env (Let (Rec pairs) body) = let (binders,rhss) = unzip pairs str_vals = fixpoint StrAnal binders rhss str_env @@ -275,10 +320,9 @@ saExpr str_env abs_env (Let (Rec pairs) body) new_str_env = growAbsValEnvList str_env (binders `zip` str_vals) new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals) in - saExpr new_str_env new_abs_env body `thenSa` \ new_body -> - mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> + saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body -> + mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> let --- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders -- DON'T add demand info in a Rec! -- a) it's useless: we can't do let-to-case -- b) it's incorrect. Consider @@ -290,8 +334,8 @@ saExpr str_env abs_env (Let (Rec pairs) body) -- deciding that y is absent, which is plain wrong! -- It's much easier simply not to do this. - improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId - str_vals abs_vals binders rhss + improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId + str_vals abs_vals binders new_pairs = improved_binders `zip` new_rhss in @@ -321,46 +365,23 @@ addStrictnessInfoToId :: AbsVal -- Abstract strictness value -> AbsVal -- Ditto absence -> Id -- The id - -> CoreExpr -- Its RHS -> Id -- Augmented with strictness -addStrictnessInfoToId str_val abs_val binder body - = binder `setIdStrictness` mkStrictnessInfo strictness - where - arg_tys = collect_arg_tys (idType binder) - strictness = findStrictness arg_tys str_val abs_val - - collect_arg_tys ty - | null arg_tys = [] - | otherwise = arg_tys ++ collect_arg_tys res_ty - where - (arg_tys, res_ty) = splitFunTys (repType ty) - -- repType looks through for-alls and new-types. And since we look on the - -- type info, we aren't confused by INLINE prags. - -- In particular, foldr is marked INLINE, - -- but we still want it to be strict in its third arg, so that - -- foldr k z (case e of p -> build g) - -- gets transformed to - -- case e of p -> foldr k z (build g) - -- [foldr is only inlined late in compilation, after strictness analysis] +addStrictnessInfoToId str_val abs_val binder + = binder `setIdStrictness` findStrictness binder str_val abs_val \end{code} \begin{code} -addDemandInfoToId :: StrictEnv -> AbsenceEnv +addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -- The scope of the id -> Id -> Id -- Id augmented with Demand info -addDemandInfoToId str_env abs_env expr binder - = binder `setIdDemandInfo` (findDemand str_env abs_env expr binder) - -addDemandInfoToCaseBndr str_env abs_env alts binder - = binder `setIdDemandInfo` (findDemandAlts str_env abs_env alts binder) - -addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id] +addDemandInfoToId dmd str_env abs_env expr binder + = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder) -addDemandInfoToIds str_env abs_env expr binders - = map (addDemandInfoToId str_env abs_env expr) binders +addDemandInfoToCaseBndr dmd str_env abs_env alts binder + = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder) \end{code} %************************************************************************ @@ -419,7 +440,7 @@ tick_demanded var (tot, demanded) | isTyVar var = (tot, demanded) | otherwise = (tot + 1, - if (isStrict (getIdDemandInfo var)) + if (isStrict (idDemandInfo var)) then demanded + 1 else demanded) @@ -448,8 +469,13 @@ tickLet var = panic "OMIT_STRANAL_STATS: tickLet" mapSa :: (a -> SaM b) -> [a] -> SaM [b] mapSa f [] = returnSa [] -mapSa f (x:xs) - = f x `thenSa` \ r -> - mapSa f xs `thenSa` \ rs -> - returnSa (r:rs) +mapSa f (x:xs) = f x `thenSa` \ r -> + mapSa f xs `thenSa` \ rs -> + returnSa (r:rs) + +sequenceSa :: [SaM a] -> SaM [a] +sequenceSa [] = returnSa [] +sequenceSa (m:ms) = m `thenSa` \ r -> + sequenceSa ms `thenSa` \ rs -> + returnSa (r:rs) \end{code} diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 9ae59c49c9..b6d021a67f 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -9,22 +9,21 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where #include "HsVersions.h" import CoreSyn -import CoreUnfold ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance ) +import CoreUnfold ( Unfolding, certainlyWillInline ) import CmdLineOpts ( opt_UF_CreationThreshold , opt_D_verbose_core2core, opt_D_dump_worker_wrapper ) import CoreLint ( beginPass, endPass ) -import CoreUtils ( coreExprType, exprEtaExpandArity ) -import Const ( Con(..) ) +import CoreUtils ( exprType, exprArity, exprEtaExpandArity, mkInlineMe ) import DataCon ( DataCon ) import MkId ( mkWorkerId ) -import Id ( Id, idType, getIdStrictness, setIdArity, isOneShotLambda, - setIdStrictness, getIdDemandInfo, getInlinePragma, - setIdWorkerInfo, getIdCprInfo ) +import Id ( Id, idType, idStrictness, setIdArityInfo, isOneShotLambda, + setIdStrictness, idDemandInfo, idInlinePragma, + setIdWorkerInfo, idCprInfo, setInlinePragma ) import VarSet import Type ( Type, isNewType, splitForAllTys, splitFunTys ) import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..), - CprInfo(..), exactArity, InlinePragInfo(..) + CprInfo(..), exactArity, InlinePragInfo(..), WorkerInfo(..) ) import Demand ( Demand, wwLazy ) import SaLib @@ -125,17 +124,13 @@ wwBind (Rec pairs) annotations that can be used. Remember it is @wwBind@ that does the matching by looking for strict arguments of the correct type. @wwExpr@ is a version that just returns the ``Plain'' Tree. -???????????????? ToDo \begin{code} wwExpr :: CoreExpr -> UniqSM CoreExpr wwExpr e@(Type _) = returnUs e wwExpr e@(Var _) = returnUs e - -wwExpr e@(Con con args) - = mapUs wwExpr args `thenUs` \ args' -> - returnUs (Con con args') +wwExpr e@(Lit _) = returnUs e wwExpr (Lam binder expr) = wwExpr expr `thenUs` \ new_expr -> @@ -194,34 +189,47 @@ tryWW :: Bool -- True <=> a non-recursive binding -- if two, then a worker and a -- wrapper. tryWW non_rec fn_id rhs - | (non_rec && -- Don't split if its non-recursive and small - certainlySmallEnoughToInline (calcUnfoldingGuidance opt_UF_CreationThreshold rhs) + | non_rec + && certainlyWillInline fn_id -- No point in worker/wrappering something that is going to be -- INLINEd wholesale anyway. If the strictness analyser is run -- twice, this test also prevents wrappers (which are INLINEd) -- from being re-done. - ) - - || arity == 0 -- Don't split if it's not a function - || never_inline fn_id + -- + -- OUT OF DATE NOTE: + -- In this case we add an INLINE pragma to the RHS. Why? + -- Because consider + -- f = \x -> g x x + -- g = \yz -> ... -- And g is strict + -- Then f is small, so we don't w/w it. But g is big, and we do, so + -- g's wrapper will get inlined in f's RHS, which makes f look big now. + -- So f doesn't get inlined, but it is strict and we have failed to w/w it. + -- It's out of date because now wrappers look very cheap + -- even when they are inlined. + = returnUs [ (fn_id, rhs) ] - || not (do_strict_ww || do_cpr_ww || do_coerce_ww) + | not (do_strict_ww || do_cpr_ww || do_coerce_ww) = returnUs [ (fn_id, rhs) ] | otherwise -- Do w/w split - = mkWwBodies fun_ty arity wrap_dmds one_shots cpr_info `thenUs` \ (work_args, wrap_fn, work_fn) -> - getUniqueUs `thenUs` \ work_uniq -> + = mkWwBodies fun_ty arity wrap_dmds result_bot one_shots cpr_info `thenUs` \ (work_demands, wrap_fn, work_fn) -> + getUniqueUs `thenUs` \ work_uniq -> let - work_rhs = work_fn rhs - work_demands = [getIdDemandInfo v | v <- work_args, isId v] - proto_work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) + work_rhs = work_fn rhs + proto_work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) + `setInlinePragma` inline_prag + work_id | has_strictness = proto_work_id `setIdStrictness` mkStrictnessInfo (work_demands, result_bot) | otherwise = proto_work_id + wrap_arity = exprArity wrap_rhs -- Might be greater than the current visible arity + -- if the function returns bottom + wrap_rhs = wrap_fn work_id wrap_id = fn_id `setIdStrictness` wrapper_strictness - `setIdWorkerInfo` Just work_id - `setIdArity` exactArity arity + `setIdWorkerInfo` HasWorker work_id wrap_arity + `setIdArityInfo` exactArity wrap_arity + `setInlinePragma` NoInlinePragInfo -- Put it on the worker instead -- Add info to the wrapper: -- (a) we want to set its arity -- (b) we want to pin on its revised strictness info @@ -234,38 +242,44 @@ tryWW non_rec fn_id rhs arity = exprEtaExpandArity rhs -- Don't split something which is marked unconditionally NOINLINE - never_inline fn_id = case getInlinePragma fn_id of - IMustNotBeINLINEd False Nothing -> True - other -> False - - strictness_info = getIdStrictness fn_id - StrictnessInfo arg_demands result_bot = strictness_info - has_strictness = case strictness_info of - StrictnessInfo _ _ -> True - other -> False - - do_strict_ww = has_strictness && worthSplitting wrap_dmds result_bot - - -- NB: There maybe be more items in arg_demands than arity, because - -- the strictness info is semantic and looks through InlineMe and Scc Notes, - -- whereas arity does not - demands_for_visible_args = take arity arg_demands - remaining_arg_demands = drop arity arg_demands - - wrap_dmds | has_strictness = setUnpackStrategy demands_for_visible_args - | otherwise = take arity (repeat wwLazy) - - wrapper_strictness | has_strictness = mkStrictnessInfo (wrap_dmds ++ remaining_arg_demands, result_bot) + inline_prag = idInlinePragma fn_id + + strictness_info = idStrictness fn_id + has_strictness = case strictness_info of + StrictnessInfo _ _ -> True + NoStrictnessInfo -> False + (arg_demands, result_bot) = case strictness_info of + StrictnessInfo d r -> (d, r) + NoStrictnessInfo -> ([], False) + + wrap_dmds = setUnpackStrategy arg_demands + do_strict_ww = WARN( has_strictness && not result_bot && arity < length arg_demands && worthSplitting wrap_dmds result_bot, + text "Insufficient arity" <+> ppr fn_id <+> ppr arity <+> ppr arg_demands ) + (result_bot || arity >= length arg_demands) -- Only if there's enough visible arity + && -- (else strictness info isn't valid) + -- + worthSplitting wrap_dmds result_bot -- And it's useful + -- worthSplitting returns False for an empty list of demands, + -- and hence do_strict_ww is False if arity is zero + -- Also it's false if there is no strictness (arg_demands is []) + + wrapper_strictness | has_strictness = mkStrictnessInfo (wrap_dmds, result_bot) | otherwise = noStrictnessInfo ------------------------------------------------------------- - cpr_info = getIdCprInfo fn_id - do_cpr_ww = case cpr_info of - CPRInfo _ -> True - other -> False + cpr_info = idCprInfo fn_id + do_cpr_ww = arity > 0 && + case cpr_info of + ReturnsCPR -> True + other -> False ------------------------------------------------------------- do_coerce_ww = check_for_coerce arity fun_ty + -- We are willing to do a w/w even if the arity is zero. + -- x = coerce t E + -- ==> + -- x' = E + -- x = coerce t x' ------------------------------------------------------------- one_shots = get_one_shots rhs @@ -312,11 +326,12 @@ the function and the name of its worker, and we want to make its body (the wrapp mkWrapper :: Type -- Wrapper type -> Int -- Arity -> [Demand] -- Wrapper strictness info + -> Bool -- Function returns bottom -> CprInfo -- Wrapper cpr info -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id -mkWrapper fun_ty arity demands cpr_info - = mkWwBodies fun_ty arity demands noOneShotInfo cpr_info `thenUs` \ (_, wrap_fn, _) -> +mkWrapper fun_ty arity demands res_bot cpr_info + = mkWwBodies fun_ty arity demands res_bot noOneShotInfo cpr_info `thenUs` \ (_, wrap_fn, _) -> returnUs wrap_fn noOneShotInfo = repeat False diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 170e10b6f7..be6f333b72 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -12,27 +12,26 @@ module WwLib ( #include "HsVersions.h" import CoreSyn -import CoreUtils ( coreExprType ) -import Id ( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo, +import CoreUtils ( exprType, mkInlineMe ) +import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo, isOneShotLambda, setOneShotLambda, mkWildId, setIdInfo ) import IdInfo ( CprInfo(..), noCprInfo, vanillaIdInfo ) -import Const ( Con(..), DataCon ) -import DataCon ( isExistentialDataCon, dataConArgTys ) -import Demand ( Demand(..) ) +import DataCon ( DataCon, splitProductType ) +import Demand ( Demand(..), wwLazy, wwPrim ) import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID ) import TysPrim ( realWorldStatePrimTy ) import TysWiredIn ( unboxedTupleCon, unboxedTupleTyCon ) import Type ( isUnLiftedType, - splitForAllTys, splitFunTys, + splitForAllTys, splitFunTys, isAlgType, splitAlgTyConApp_maybe, splitNewType_maybe, mkTyConApp, mkFunTys, Type ) import TyCon ( isNewTyCon, isProductTyCon, TyCon ) import BasicTypes ( NewOrData(..), Arity ) -import Var ( TyVar, IdOrTyVar ) +import Var ( TyVar, Var, isId ) import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, mapUs, UniqSM ) import Util ( zipWithEqual, zipEqual, lengthExceeds ) @@ -187,11 +186,8 @@ worthSplitting :: [Demand] -> Bool -- True <=> the wrapper would not be an identity function worthSplitting ds result_bot = any worth_it ds -- We used not to split if the result is bottom. - -- [Justification: there's no efficiency to be gained, - -- and (worse) the wrapper body may not look like a wrapper - -- body to getWorkerIdAndCons] - -- But now (a) we don't have getWorkerIdAndCons, and - -- (b) it's sometimes bad not to make a wrapper. Consider + -- [Justification: there's no efficiency to be gained.] + -- But it's sometimes bad not to make a wrapper. Consider -- fw = \x# -> let x = I# x# in case e of -- p1 -> error_fn x -- p2 -> error_fn x @@ -225,24 +221,25 @@ allAbsent ds = all absent ds mkWwBodies :: Type -- Type of original function -> Arity -- Arity of original function -> [Demand] -- Strictness of original function + -> Bool -- True <=> function returns bottom -> [Bool] -- One-shot-ness of the function -> CprInfo -- Result of CPR analysis - -> UniqSM ([IdOrTyVar], -- Worker args + -> UniqSM ([Demand], -- Demands for worker (value) args Id -> CoreExpr, -- Wrapper body, lacking only the worker Id CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs -mkWwBodies fun_ty arity demands one_shots cpr_info - = WARN( not (lengthExceeds demands (arity-1)) - || not (lengthExceeds one_shots (arity-1)), - text "mkWrapper" <+> ppr fun_ty <+> ppr arity <+> ppr (take arity demands) <+> ppr (take arity one_shots) ) - mkWWargs fun_ty arity demands one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> - mkWWstr wrap_args `thenUs` \ (work_args, wrap_fn_str, work_fn_str) -> - mkWWcpr res_ty cpr_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) -> - mkWWfixup cpr_res_ty work_args `thenUs` \ (wrap_fn_fixup, work_fn_fixup) -> - - returnUs (work_args, - Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . wrap_fn_fixup . Var, +mkWwBodies fun_ty arity demands res_bot one_shots cpr_info + = mkWWargs fun_ty arity demands' res_bot one_shots' `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> + mkWWstr wrap_args `thenUs` \ (work_dmds, wrap_fn_str, work_fn_str) -> + mkWWcpr res_ty cpr_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) -> + mkWWfixup cpr_res_ty work_dmds `thenUs` \ (final_work_dmds, wrap_fn_fixup, work_fn_fixup) -> + + returnUs (final_work_dmds, + mkInlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . wrap_fn_fixup . Var, work_fn_fixup . work_fn_str . work_fn_cpr . work_fn_args) + where + demands' = demands ++ repeat wwLazy + one_shots' = one_shots ++ repeat False \end{code} @@ -279,52 +276,60 @@ Now we'll see that fw has arity 1, and will arity expand the \x to get what we want. \begin{code} --- mkWWargs is driven off the function type. +-- mkWWargs is driven off the function type and arity. -- It chomps bites off foralls, arrows, newtypes -- and keeps repeating that until it's satisfied the supplied arity -mkWWargs :: Type -> Arity - -> [Demand] -> [Bool] -- Both these will in due course be derived +mkWWargs :: Type -> Arity + -> [Demand] -> Bool -> [Bool] -- Both these will in due course be derived -- from the type. The [Bool] is True for a one-shot arg. - -> UniqSM ([IdOrTyVar], -- Wrapper args + -- ** Both are infinite, extended with neutral values if necy ** + -> UniqSM ([Var], -- Wrapper args CoreExpr -> CoreExpr, -- Wrapper fn CoreExpr -> CoreExpr, -- Worker fn Type) -- Type of wrapper body -mkWWargs fun_ty arity demands one_shots - | arity == 0 - = returnUs ([], id, id, fun_ty) - - | otherwise +mkWWargs fun_ty arity demands res_bot one_shots + | (res_bot || arity > 0) && (not (null tyvars) || n_arg_tys > 0) + -- If the function returns bottom, we feel free to + -- build lots of wrapper args: + -- \x. let v=E in \y. bottom + -- = \xy. let v=E in bottom = getUniquesUs n_args `thenUs` \ wrap_uniqs -> let val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots wrap_args = tyvars ++ val_args in - mkWWargs body_rep_ty + mkWWargs new_fun_ty (arity - n_args) (drop n_args demands) + res_bot (drop n_args one_shots) `thenUs` \ (more_wrap_args, wrap_fn_args, work_fn_args, res_ty) -> returnUs (wrap_args ++ more_wrap_args, - mkLams wrap_args . wrap_coerce_fn . wrap_fn_args, - work_fn_args . work_coerce_fn . applyToVars wrap_args, + mkLams wrap_args . wrap_fn_args, + work_fn_args . applyToVars wrap_args, res_ty) where (tyvars, tau) = splitForAllTys fun_ty (arg_tys, body_ty) = splitFunTys tau n_arg_tys = length arg_tys - n_args = arity `min` n_arg_tys - (wrap_coerce_fn, work_coerce_fn, body_rep_ty) - | n_arg_tys == n_args -- All arg_tys used up - = case splitNewType_maybe body_ty of - Just rep_ty -> (Note (Coerce body_ty rep_ty), Note (Coerce rep_ty body_ty), rep_ty) - Nothing -> ASSERT2( n_args /= 0, text "mkWWargs" <+> ppr arity <+> ppr fun_ty ) - (id, id, body_ty) - | otherwise -- Leftover arg-tys - = (id, id, mkFunTys (drop n_args arg_tys) body_ty) - -applyToVars :: [IdOrTyVar] -> CoreExpr -> CoreExpr + n_args | res_bot = n_arg_tys + | otherwise = arity `min` n_arg_tys + new_fun_ty | n_args == n_arg_tys = body_ty + | otherwise = mkFunTys (drop n_args arg_tys) body_ty + +mkWWargs fun_ty arity demands res_bot one_shots + = case splitNewType_maybe fun_ty of + Nothing -> returnUs ([], id, id, fun_ty) + Just rep_ty -> mkWWargs rep_ty arity demands res_bot one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> + returnUs (wrap_args, + Note (Coerce fun_ty rep_ty) . wrap_fn_args, + work_fn_args . Note (Coerce rep_ty fun_ty), + res_ty) + + +applyToVars :: [Var] -> CoreExpr -> CoreExpr applyToVars vars fn = mkVarApps fn vars mk_wrap_arg uniq ty dmd one_shot @@ -342,8 +347,8 @@ mk_wrap_arg uniq ty dmd one_shot %************************************************************************ \begin{code} -mkWWfixup res_ty work_args - | null work_args && isUnLiftedType res_ty +mkWWfixup res_ty work_dmds + | null work_dmds && isUnLiftedType res_ty -- Horrid special case. If the worker would have no arguments, and the -- function returns a primitive type value, that would make the worker into -- an unboxed value. We box it by passing a dummy void argument, thus: @@ -356,11 +361,12 @@ mkWWfixup res_ty work_args let void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy in - returnUs (\ call_to_worker -> App call_to_worker (Var realWorldPrimId), + returnUs ([wwPrim], + \ call_to_worker -> App call_to_worker (Var realWorldPrimId), \ worker_body -> Lam void_arg worker_body) | otherwise - = returnUs (id, id) + = returnUs (work_dmds, id, id) \end{code} @@ -371,9 +377,9 @@ mkWWfixup res_ty work_args %************************************************************************ \begin{code} -mkWWstr :: [IdOrTyVar] -- Wrapper args; have their demand info on them +mkWWstr :: [Var] -- Wrapper args; have their demand info on them -- *Includes type variables* - -> UniqSM ([IdOrTyVar], -- Worker args + -> UniqSM ([Demand], -- Demand on worker (value) args CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call -- and without its lambdas -- This fn adds the unboxing, and makes the @@ -384,7 +390,7 @@ mkWWstr :: [IdOrTyVar] -- Wrapper args; have their demand info on them mkWWstr wrap_args = mk_ww_str wrap_args `thenUs` \ (work_args, wrap_fn, work_fn) -> - returnUs ( work_args, + returnUs ( [idDemandInfo v | v <- work_args, isId v], \ wrapper_body -> wrap_fn (mkVarApps wrapper_body work_args), \ worker_body -> mkLams work_args (work_fn worker_body)) @@ -401,7 +407,7 @@ mk_ww_str (arg : ds) returnUs (arg : worker_args, wrap_fn, work_fn) | otherwise - = case getIdDemandInfo arg of + = case idDemandInfo arg of -- Absent case WwLazy True -> @@ -463,7 +469,11 @@ mkWWcpr :: Type -- function body type mkWWcpr body_ty NoCPRInfo = returnUs (id, id, body_ty) -- Must be just the strictness transf. -mkWWcpr body_ty (CPRInfo cpr_args) +mkWWcpr body_ty ReturnsCPR + | not (isAlgType body_ty) + = WARN( True, text "mkWWcpr: non-algebraic body type" <+> ppr body_ty ) + returnUs (id, id, body_ty) + | n_con_args == 1 && isUnLiftedType con_arg_ty1 -- Special case when there is a single result of unlifted type = getUniquesUs 2 `thenUs` \ [work_uniq, arg_uniq] -> @@ -472,7 +482,7 @@ mkWWcpr body_ty (CPRInfo cpr_args) arg = mk_ww_local arg_uniq con_arg_ty1 in returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], mkConApp data_con (map Type tycon_arg_tys ++ [Var arg]))], - \ body -> Case body work_wild [(DataCon data_con, [arg], Var arg)], + \ body -> Case body work_wild [(DataAlt data_con, [arg], Var arg)], con_arg_ty1) | otherwise -- The general case @@ -481,48 +491,17 @@ mkWWcpr body_ty (CPRInfo cpr_args) (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys) arg_vars = map Var args ubx_tup_con = unboxedTupleCon n_con_args - ubx_tup_ty = coreExprType ubx_tup_app + ubx_tup_ty = exprType ubx_tup_app ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars) con_app = mkConApp data_con (map Type tycon_arg_tys ++ arg_vars) in - returnUs (\ wkr_call -> Case wkr_call wrap_wild [(DataCon ubx_tup_con, args, con_app)], - \ body -> Case body work_wild [(DataCon data_con, args, ubx_tup_app)], + returnUs (\ wkr_call -> Case wkr_call wrap_wild [(DataAlt ubx_tup_con, args, con_app)], + \ body -> Case body work_wild [(DataAlt data_con, args, ubx_tup_app)], ubx_tup_ty) where (tycon, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty n_con_args = length con_arg_tys con_arg_ty1 = head con_arg_tys - - -splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type]) - -- For a tiresome reason, the type might not look like a product type - -- This happens when compiling the compiler! The module Name - -- imports {-# SOURCE #-} TyCon and Id - -- data Name = Name NameSort Unique OccName Provenance - -- data NameSort = WiredInId Module Id | ... - -- So Name does not look recursive (because Id is imported via a hi-boot file, - -- which says nothing about Id's rep) but actually it is, because Ids have Names. - -- Modules that *import* Name have a more complete view, see that Name is recursive, - -- and therefore that it isn't a ProductType. This conflicts with the CPR info - -- in exports from Name that say "do CPR". - -- - -- Arguably we should regard Name as a product anyway because it isn't recursive - -- via products all the way... but we don't have that info to hand, and even if - -- we did this case might *still* arise. - - -- - -- So we hack our way out for now, by trusting the pragma that said "do CPR" - -- that means we can't use splitProductType_maybe - -splitProductType fname ty - = case splitAlgTyConApp_maybe ty of - Just (tycon, tycon_args, (con:other_cons)) - | null other_cons && not (isExistentialDataCon con) - -> WARN( not (isProductTyCon tycon), - text "splitProductType hack: I happened!" <+> ppr ty ) - (tycon, tycon_args, con, dataConArgTys con tycon_args) - - other -> pprPanic (fname ++ ": not a product") (ppr ty) \end{code} @@ -555,7 +534,7 @@ mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body -- A data type = Case (Var arg) (sanitiseCaseBndr arg) - [(DataCon boxing_con, unpk_args, body)] + [(DataAlt boxing_con, unpk_args, body)] sanitiseCaseBndr :: Id -> Id -- The argument we are scrutinising has the right type to be @@ -575,7 +554,7 @@ mk_pk_let NewType arg boxing_con con_tys unpk_args body (unpk_arg:other_args) = unpk_args mk_pk_let DataType arg boxing_con con_tys unpk_args body - = Let (NonRec arg (Con (DataCon boxing_con) con_args)) body + = Let (NonRec arg (mkConApp boxing_con con_args)) body where con_args = map Type con_tys ++ map Var unpk_args diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index ecc9a2f7f3..aa6549833d 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -39,7 +39,7 @@ module Inst ( import HsSyn ( HsLit(..), HsExpr(..) ) import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat ) import TcHsSyn ( TcExpr, TcId, - mkHsTyApp, mkHsDictApp, mkHsDictLam, zonkId + mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId ) import TcMonad import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey ) @@ -69,13 +69,14 @@ import Subst ( emptyInScopeSet, mkSubst, substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst ) import TyCon ( TyCon ) +import Literal ( inIntRange ) import Var ( TyVar ) import VarEnv ( lookupVarEnv, TidyEnv, lookupSubstEnv, SubstResult(..) ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet ) import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy ) -import TysWiredIn ( intDataCon, isIntTy, inIntRange, +import TysWiredIn ( intDataCon, isIntTy, floatDataCon, isFloatTy, doubleDataCon, isDoubleTy, integerTy, isIntegerTy @@ -452,7 +453,7 @@ newOverloadedLit orig (OverloadedIntegral i) ty where intprim_lit = HsLitOut (HsIntPrim i) intPrimTy integer_lit = HsLitOut (HsInt i) integerTy - int_lit = HsCon intDataCon [] [intprim_lit] + int_lit = mkHsConApp intDataCon [] [intprim_lit] newOverloadedLit orig lit ty -- The general case = tcGetInstLoc orig `thenNF_Tc` \ loc -> @@ -710,7 +711,7 @@ lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc) in_int_range = inIntRange i intprim_lit = HsLitOut (HsIntPrim i) intPrimTy integer_lit = HsLitOut (HsInt i) integerTy - int_lit = HsCon intDataCon [] [intprim_lit] + int_lit = mkHsConApp intDataCon [] [intprim_lit] -- similar idea for overloaded floating point literals: if the literal is -- *definitely* a float or a double, generate the real thing here. @@ -721,7 +722,7 @@ lookupInst inst@(LitInst u (OverloadedFractional f) ty loc) | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit) | otherwise - = tcLookupValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational -> + = tcLookupValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational -> -- The type Rational isn't wired in so we have to conjure it up tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon -> @@ -734,9 +735,9 @@ lookupInst inst@(LitInst u (OverloadedFractional f) ty loc) where floatprim_lit = HsLitOut (HsFloatPrim f) floatPrimTy - float_lit = HsCon floatDataCon [] [floatprim_lit] + float_lit = mkHsConApp floatDataCon [] [floatprim_lit] doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy - double_lit = HsCon doubleDataCon [] [doubleprim_lit] + double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit] -- there are no `instances' of functional dependencies or implicit params diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index bd07d222aa..ccfd18a5a3 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -4,7 +4,7 @@ \section[TcClassDcl]{Typechecking class declarations} \begin{code} -module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, +module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, mkImplicitClassBinds, tcMethodBind, checkFromThisClass ) where @@ -23,7 +23,7 @@ import RnHsSyn ( RenamedTyClDecl, RenamedClassPragmas, RenamedClassOpSig, RenamedMonoBinds, RenamedContext, RenamedHsDecl, RenamedSig ) -import TcHsSyn ( TcMonoBinds ) +import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod ) import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo, @@ -38,14 +38,15 @@ import TcMonoType ( tcHsType, tcHsTopType, tcExtendTopTyVarScope, ) import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns ) import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar ) +import TcInstUtil ( classDataCon ) import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) import FieldLabel ( firstFieldLabelTag ) import Bag ( unionManyBags, bagToList ) import Class ( mkClass, classBigSig, classSelIds, Class, ClassOpItem ) import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods ) -import MkId ( mkDictSelId, mkDataConId, mkDefaultMethodId ) -import DataCon ( mkDataCon, notMarkedStrict ) -import Id ( Id, setInlinePragma, getIdUnfolding, idType, idName ) +import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) +import DataCon ( mkDataCon, dataConId, dataConWrapId, notMarkedStrict ) +import Id ( Id, setInlinePragma, idUnfolding, idType, idName ) import CoreUnfold ( unfoldingTemplate ) import IdInfo import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) ) @@ -109,7 +110,7 @@ Death to "ExpandingDicts". \begin{code} kcClassDecl (ClassDecl context class_name tyvar_names fundeps class_sigs def_methods pragmas - tycon_name datacon_name sc_sel_names src_loc) + _ _ _ _ src_loc) = -- CHECK ARITY 1 FOR HASKELL 1.4 checkTc (opt_GlasgowExts || length tyvar_names == 1) (classArityErr class_name) `thenTc_` @@ -141,7 +142,7 @@ kcClassDecl (ClassDecl context class_name tcClassDecl1 rec_env rec_inst_mapper rec_vrcs (ClassDecl context class_name tyvar_names fundeps class_sigs def_methods pragmas - tycon_name datacon_name sc_sel_names src_loc) + tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc) = -- LOOK THINGS UP IN THE ENVIRONMENT tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) -> tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ -> @@ -182,9 +183,10 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs [{-No context-}] [{-No existential tyvars-}] [{-Or context-}] dict_component_tys - tycon dict_con_id + tycon dict_con_id dict_wrap_id - dict_con_id = mkDataConId dict_con + dict_con_id = mkDataConId datacon_wkr_name dict_con + dict_wrap_id = mkDataConWrapId dict_con argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $ ppr tycon_name) @@ -342,7 +344,7 @@ tcClassDecl2 :: RenamedTyClDecl -- The class declaration -> NF_TcM s (LIE, TcMonoBinds) tcClassDecl2 (ClassDecl context class_name - tyvar_names _ class_sigs default_binds pragmas _ _ _ src_loc) + tyvar_names _ class_sigs default_binds pragmas _ _ _ _ src_loc) | not (isLocallyDefined class_name) = returnNF_Tc (emptyLIE, EmptyMonoBinds) @@ -350,20 +352,27 @@ tcClassDecl2 (ClassDecl context class_name | otherwise -- It is locally defined = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ tcAddSrcLoc src_loc $ - - -- Get the relevant class tcLookupClass class_name `thenNF_Tc` \ clas -> - let + tcDefaultMethodBinds clas default_binds class_sigs +\end{code} + +\begin{code} +mkImplicitClassBinds :: [Class] -> NF_TcM s ([Id], TcMonoBinds) +mkImplicitClassBinds classes + = returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s) -- The selector binds are already in the selector Id's unfoldings - sel_binds = [ CoreMonoBind sel_id (unfoldingTemplate (getIdUnfolding sel_id)) - | sel_id <- classSelIds clas - ] - in - -- Generate bindings for the default methods - tcDefaultMethodBinds clas default_binds class_sigs `thenTc` \ (const_insts, meth_binds) -> + where + (cls_ids_s, binds_s) = unzip (map mk_implicit classes) + + mk_implicit clas = (all_cls_ids, binds) + where + dict_con = classDataCon clas + all_cls_ids = dataConId dict_con : cls_ids + cls_ids = dataConWrapId dict_con : classSelIds clas - returnTc (const_insts, - meth_binds `AndMonoBinds` andMonoBindList sel_binds) + -- The wrapper and selectors get bindings, the worker does not + binds | isLocallyDefined clas = idsToMonoBinds cls_ids + | otherwise = EmptyMonoBinds \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 6b13551a60..8e546feab2 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -33,7 +33,7 @@ module TcEnv( #include "HsVersions.h" import HsTypes ( HsTyVar, getTyVarName ) -import Id ( mkUserLocal, isDataConId_maybe ) +import Id ( mkUserLocal, isDataConWrapId_maybe ) import MkId ( mkSpecPragmaId ) import Var ( TyVar, Id, setVarName, idType, lazySetIdInfo, idInfo, tyVarKind, UVar, @@ -89,7 +89,7 @@ type TcIdSet = IdSet tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType) tcLookupDataCon con_name = tcLookupValue con_name `thenNF_Tc` \ con_id -> - case isDataConId_maybe con_id of { + case isDataConWrapId_maybe con_id of { Nothing -> failWithTc (badCon con_id); Just data_con -> diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index a9880a255a..9ab1460406 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -13,7 +13,7 @@ import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), mkMonoBind, nullMonoBinds ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, +import TcHsSyn ( TcExpr, TcRecordBinds, mkHsConApp, mkHsTyApp, mkHsLet, maybeBoxedPrimType ) @@ -50,7 +50,7 @@ import Id ( idType, recordSelectorFieldLabel, isRecordSelector, Id, mkVanillaId ) -import DataCon ( dataConFieldLabels, dataConSig, dataConId, +import DataCon ( dataConFieldLabels, dataConSig, dataConStrictMarks, StrictnessMark(..) ) import Name ( Name, getName ) @@ -354,7 +354,7 @@ arg/result types); unify them with the args/result; and store them for later use. \begin{code} -tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty +tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty = -- Get the callable and returnable classes. tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass -> @@ -390,8 +390,7 @@ tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty -- constraints on the argument and result types. mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s -> newClassDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) -> - returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty]) - (CCall lbl args' may_gc is_asm result_ty), + returnTc (mkHsConApp ioDataCon [result_ty] [HsCCall lbl args' may_gc is_asm result_ty], -- do the wrapping in the newtype constructor here foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie) \end{code} @@ -480,11 +479,11 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty let (_, record_ty) = splitFunTys con_tau in - -- Con is syntactically constrained to be a data constructor ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) ) unifyTauTy res_ty record_ty `thenTc_` -- Check that the record bindings match the constructor + -- con_name is syntactically constrained to be a data constructor tcLookupDataCon con_name `thenTc` \ (data_con, _, _) -> let bad_fields = badFields rbinds data_con diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index b1fd17ecdb..58c73ab36f 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -20,7 +20,7 @@ module TcForeign #include "HsVersions.h" import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), - ExtName(..), isDynamic, MonoBinds(..), + ExtName(Dynamic), isDynamicExtName, MonoBinds(..), OutPat(..), ForKind(..) ) import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) @@ -82,7 +82,7 @@ isForeignImport (ForeignDecl _ k _ dyn _ _) = -- exports a binding isForeignExport :: ForeignDecl name -> Bool -isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamic ext_nm) +isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamicExtName ext_nm) isForeignExport _ = False \end{code} @@ -131,7 +131,7 @@ tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_ in case splitFunTys t_ty of (arg_tys, res_ty) -> - checkForeignImport (isDynamic ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_` + checkForeignImport (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_` let i = (mkVanillaId nm ty) in returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc)) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index d4bd29b563..b87355d2ba 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -22,8 +22,9 @@ module TcHsSyn ( TypecheckedGRHSs, TypecheckedGRHS, TypecheckedRecordBinds, TypecheckedDictBinds, - mkHsTyApp, mkHsDictApp, + mkHsTyApp, mkHsDictApp, mkHsConApp, mkHsTyLam, mkHsDictLam, mkHsLet, + idsToMonoBinds, -- re-exported from TcEnv TcId, tcInstId, @@ -40,8 +41,8 @@ module TcHsSyn ( import HsSyn -- oodles of it -- others: -import Id ( idName, idType, setIdType, omitIfaceSigForId, isIP, Id ) -import DataCon ( DataCon, splitProductType_maybe ) +import Id ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id ) +import DataCon ( DataCon, dataConWrapId, splitProductType_maybe ) import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv, ValueEnv, TcId, tcInstId ) @@ -57,6 +58,7 @@ import Var ( TyVar ) import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList ) import VarSet ( isEmptyVarSet ) import CoreSyn ( Expr ) +import CoreUnfold( unfoldingTemplate ) import BasicTypes ( RecFlag(..) ) import Bag import UniqFM @@ -123,6 +125,14 @@ mkHsDictLam dicts expr = DictLam dicts expr mkHsLet EmptyMonoBinds expr = expr mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr + +mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args + +idsToMonoBinds :: [Id] -> TcMonoBinds +idsToMonoBinds ids + = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id)) + | id <- ids + ] \end{code} %************************************************************************ @@ -433,11 +443,6 @@ zonkExpr (ExplicitTuple exprs boxed) = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitTuple new_exprs boxed) -zonkExpr (HsCon data_con tys exprs) - = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys -> - mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> - returnNF_Tc (HsCon data_con new_tys new_exprs) - zonkExpr (RecordConOut data_con con_expr rbinds) = zonkExpr con_expr `thenNF_Tc` \ new_con_expr -> zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> @@ -460,10 +465,10 @@ zonkExpr (ArithSeqOut expr info) zonkArithSeq info `thenNF_Tc` \ new_info -> returnNF_Tc (ArithSeqOut new_expr new_info) -zonkExpr (CCall fun args may_gc is_casm result_ty) +zonkExpr (HsCCall fun args may_gc is_casm result_ty) = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args -> zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty -> - returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty) + returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty) zonkExpr (HsSCC lbl expr) = zonkExpr expr `thenNF_Tc` \ new_expr -> diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 6eae048d92..57ff4c0319 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -18,29 +18,29 @@ import TcMonoType ( tcHsType, tcHsTypeKind, ) import TcEnv ( ValueEnv, tcExtendTyVarEnv, tcExtendGlobalValEnv, tcSetValueEnv, - tcLookupTyConByKey, tcLookupValueMaybe, + tcLookupValueMaybe, explicitLookupValue, badCon, badPrimOp, valueEnvIds ) import TcType ( TcKind, kindToTcKind ) import RnHsSyn ( RenamedHsDecl ) import HsCore -import CallConv ( cCallConv ) -import Const ( Con(..), Literal(..) ) +import Literal ( Literal(..) ) import CoreSyn -import CoreUtils ( coreExprType ) +import CoreUtils ( exprType ) import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import PrimOp ( PrimOp(..) ) +import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import Id ( Id, mkId, mkVanillaId, - isDataConId_maybe + isDataConWrapId_maybe ) +import MkId ( mkCCallOpId ) import IdInfo import DataCon ( dataConSig, dataConArgTys ) -import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, unUsgTy ) -import Var ( IdOrTyVar, mkTyVar, tyVarKind ) +import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitFunTys, unUsgTy ) +import Var ( mkTyVar, tyVarKind ) import VarEnv import Name ( Name, NamedThing(..), isLocallyDefined ) import Unique ( rationalTyConKey ) @@ -87,7 +87,7 @@ tcIdInfo unf_env in_scope_vars name ty info info_ins tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity) tcPrag info (HsUpdate upd) = returnTc (info `setUpdateInfo` upd) tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs) - tcPrag info (HsCprInfo cpr_info) = returnTc (info `setCprInfo` cpr_info) + tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR) tcPrag info (HsUnfold inline_prag expr) = tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' -> @@ -96,7 +96,7 @@ tcIdInfo unf_env in_scope_vars name ty info info_ins -- is never inspected; so the typecheck doesn't even happen unfold_info = case maybe_expr' of Nothing -> noUnfolding - Just expr' -> mkTopUnfolding expr' + Just expr' -> mkTopUnfolding (cprInfo info) expr' info1 = info `setUnfoldingInfo` unfold_info info2 = info1 `setInlinePragInfo` inline_prag in @@ -115,12 +115,12 @@ tcWorkerInfo unf_env ty info worker_name = pprPanic "Worker with no arity info" (ppr worker_name) | otherwise - = uniqSMToTcM (mkWrapper ty arity demands cpr_info) `thenNF_Tc` \ wrap_fn -> + = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn -> let -- Watch out! We can't pull on unf_env too eagerly! info' = case explicitLookupValue unf_env worker_name of - Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id) - `setWorkerInfo` Just worker_id + Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding cpr_info (wrap_fn worker_id) + `setWorkerInfo` HasWorker worker_id arity Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info in @@ -131,9 +131,9 @@ tcWorkerInfo unf_env ty info worker_name arity_info = arityInfo info arity = arityLowerBound arity_info cpr_info = cprInfo info - demands = case strictnessInfo info of - StrictnessInfo d _ -> d - _ -> take arity (repeat wwLazy) -- Noncommittal + (demands, res_bot) = case strictnessInfo info of + StrictnessInfo d r -> (d,r) + _ -> (take arity (repeat wwLazy),False) -- Noncommittal \end{code} For unfoldings we try to do the job lazily, so that we never type check @@ -200,17 +200,26 @@ tcCoreExpr (UfVar name) = tcVar name `thenTc` \ id -> returnTc (Var id) -tcCoreExpr (UfCon con args) - = mapTc tcCoreExpr args `thenTc` \ args' -> - tcUfCon con args' +tcCoreExpr (UfLit lit) + = returnTc (Lit lit) + +-- The dreaded lit-lits are also similar, except here the type +-- is read in explicitly rather than being implicit +tcCoreExpr (UfLitLit lit ty) + = tcHsType ty `thenTc` \ ty' -> + returnTc (Lit (MachLitLit lit ty')) + +tcCoreExpr (UfCCall cc ty) + = tcHsType ty `thenTc` \ ty' -> + tcGetUnique `thenNF_Tc` \ u -> + returnTc (Var (mkCCallOpId u cc ty')) tcCoreExpr (UfTuple name args) - = -- See notes with tcUfCon (UfDataCon ...) - tcVar name `thenTc` \ con_id -> + = tcVar name `thenTc` \ con_id -> mapTc tcCoreExpr args `thenTc` \ args' -> let -- Put the missing type arguments back in - con_args = map (Type . unUsgTy . coreExprType) args' ++ args' + con_args = map (Type . unUsgTy . exprType) args' ++ args' in returnTc (mkApps (Var con_id) con_args) @@ -227,7 +236,7 @@ tcCoreExpr (UfApp fun arg) tcCoreExpr (UfCase scrut case_bndr alts) = tcCoreExpr scrut `thenTc` \ scrut' -> let - scrut_ty = coreExprType scrut' + scrut_ty = exprType scrut' case_bndr' = mkVanillaId case_bndr scrut_ty in tcExtendGlobalValEnv [case_bndr'] $ @@ -253,63 +262,13 @@ tcCoreExpr (UfNote note expr) case note of UfCoerce to_ty -> tcHsType to_ty `thenTc` \ to_ty' -> returnTc (Note (Coerce (unUsgTy to_ty') - (unUsgTy (coreExprType expr'))) expr') + (unUsgTy (exprType expr'))) expr') UfInlineCall -> returnTc (Note InlineCall expr') UfInlineMe -> returnTc (Note InlineMe expr') UfSCC cc -> returnTc (Note (SCC cc) expr') tcCoreNote (UfSCC cc) = returnTc (SCC cc) tcCoreNote UfInlineCall = returnTc InlineCall - - ----------------------------------- -tcUfCon (UfLitCon lit) args - = ASSERT( null args) - tcUfLit lit `thenTc` \ lit -> - returnTc (Con (Literal lit) []) - --- The dreaded lit-lits are also similar, except here the type --- is read in explicitly rather than being implicit -tcUfCon (UfLitLitCon lit ty) args - = ASSERT( null args ) - tcHsType ty `thenTc` \ ty' -> - returnTc (Con (Literal (MachLitLit lit ty')) []) - --- Primops are reverse-engineered --- into applications of their Ids. In this way, any --- RULES that apply to the Id will work when this thing is unfolded. --- It's a bit of a hack, but it works nicely --- Can't do it for datacons, because the data con Id doesn't necessarily --- have the same type as the data con (existentials) - -tcUfCon (UfPrimOp name) args = tcVar name `thenTc` \ op_id -> - returnTc (mkApps (Var op_id) args) - -tcUfCon (UfDataCon name) args - = tcVar name `thenTc` \ con_id -> - case isDataConId_maybe con_id of - Just con -> returnTc (mkConApp con args) - Nothing -> failWithTc (badCon name) - -tcUfCon (UfCCallOp str is_dyn casm gc) args - | is_dyn = tcGetUnique `thenNF_Tc` \ u -> - returnTc (Con (PrimOp (CCallOp (Right u) casm gc cCallConv)) args) - | otherwise = returnTc (Con (PrimOp (CCallOp (Left str) casm gc cCallConv)) args) - ----------------------------------- -tcUfLit (NoRepRational lit _) - = -- rationalTy isn't built in so, we have to construct it - -- (the "ty" part of the incoming literal is simply bottom) - tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon -> - let - rational_ty = mkSynTy rational_tycon [] - in - returnTc (NoRepRational lit rational_ty) - --- Similarly for integers and strings, except that they are wired in -tcUfLit (NoRepInteger lit _) = returnTc (NoRepInteger lit integerTy) -tcUfLit (NoRepStr lit _) = returnTc (NoRepStr lit stringTy) -tcUfLit other_lit = returnTc other_lit \end{code} \begin{code} @@ -359,24 +318,24 @@ tcCoreAlt scrut_ty (UfDefault, names, rhs) tcCoreExpr rhs `thenTc` \ rhs' -> returnTc (DEFAULT, [], rhs') -tcCoreAlt scrut_ty (UfLitCon lit, names, rhs) +tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs) = ASSERT( null names ) tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (Literal lit, [], rhs') + returnTc (LitAlt lit, [], rhs') -tcCoreAlt scrut_ty (UfLitLitCon str ty, names, rhs) +tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs) = ASSERT( null names ) tcCoreExpr rhs `thenTc` \ rhs' -> tcHsType ty `thenTc` \ ty' -> - returnTc (Literal (MachLitLit str ty'), [], rhs') + returnTc (LitAlt (MachLitLit str ty'), [], rhs') -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! -tcCoreAlt scrut_ty (UfDataCon con_name, names, rhs) +tcCoreAlt scrut_ty (UfDataAlt con_name, names, rhs) = tcVar con_name `thenTc` \ con_id -> let - con = case isDataConId_maybe con_id of + con = case isDataConWrapId_maybe con_id of Just con -> con Nothing -> pprPanic "tcCoreAlt" (ppr con_id) @@ -401,7 +360,7 @@ tcCoreAlt scrut_ty (UfDataCon con_name, names, rhs) tcExtendTyVarEnv ex_tyvars' $ tcExtendGlobalValEnv arg_ids $ tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (DataCon con, ex_tyvars' ++ arg_ids, rhs') + returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs') \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index ba94e58dcf..0c32116c4c 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -14,7 +14,7 @@ import HsSyn ( HsDecl(..), InstDecl(..), andMonoBindList ) import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl ) -import TcHsSyn ( TcMonoBinds, +import TcHsSyn ( TcMonoBinds, mkHsConApp, maybeBoxedPrimType ) @@ -40,7 +40,7 @@ import Bag ( emptyBag, unitBag, unionBags, unionManyBags, import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances ) import Class ( classBigSig, Class ) import Var ( idName, idType, Id, TyVar ) -import DataCon ( isNullaryDataCon, splitProductType_maybe, dataConId ) +import DataCon ( isNullaryDataCon, splitProductType_maybe ) import Maybes ( maybeToBool, catMaybes, expectJust ) import MkId ( mkDictFunId ) import Module ( ModuleName ) @@ -327,7 +327,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys origin = InstanceDeclOrigin - (class_tyvars, sc_theta, sc_sel_ids, op_items) = classBigSig clas + (class_tyvars, sc_theta, _, op_items) = classBigSig clas dm_ids = [dm_id | (_, dm_id, _) <- op_items] @@ -439,13 +439,12 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys (HsLitOut (HsString msg) stringTy) | otherwise -- The common case - = foldl HsApp (TyApp (HsVar (dataConId dict_constr)) inst_tys') - (map HsVar (sc_dict_ids ++ meth_ids)) + = mkHsConApp dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids)) -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application -- We do this rather than generate an HsCon directly, because -- it means that the special cases (e.g. dictionary with only one - -- member) are dealt with by the common MkId.mkDataConId code rather + -- member) are dealt with by the common MkId.mkDataConWrapId code rather -- than needing to be repeated here. where diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 28a6bd48cd..4fc3937565 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -22,7 +22,7 @@ import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, import TcMonad import Inst ( Inst, emptyLIE, plusLIE ) import TcBinds ( tcTopBindsAndThen ) -import TcClassDcl ( tcClassDecls2 ) +import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv, getEnvTyCons, getEnvClasses, tcLookupValueMaybe, @@ -38,7 +38,7 @@ import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcInstUtil ( buildInstanceEnvs, classDataCon, InstInfo ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) -import TcTyDecls ( mkDataBinds ) +import TcTyDecls ( mkImplicitDataBinds ) import TcType ( TcType, typeToTcType, TcKind, kindToTcKind, newTyVarTy @@ -51,7 +51,6 @@ import Id ( Id, idType ) import Module ( pprModuleName ) import Name ( Name, nameUnique, isLocallyDefined, NamedThing(..) ) import TyCon ( TyCon, tyConKind ) -import DataCon ( dataConId ) import Class ( Class, classSelIds, classTyCon ) import Type ( mkTyConApp, mkForAllTy, boxedTypeKind, getTyVar, Type ) @@ -178,7 +177,8 @@ tcModule rn_name_supply fixities local_tycons = filter isLocallyDefined tycons local_classes = filter isLocallyDefined classes in - mkDataBinds tycons `thenTc` \ (data_ids, data_binds) -> + mkImplicitDataBinds tycons `thenTc` \ (data_ids, imp_data_binds) -> + mkImplicitClassBinds classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) -> -- Extend the global value environment with -- (a) constructors @@ -187,14 +187,12 @@ tcModule rn_name_supply fixities -- (d) default-method ids... where? I can't see where these are -- put into the envt, and I'm worried that the zonking phase -- will find they aren't there and complain. - tcExtendGlobalValEnv data_ids $ - tcExtendGlobalValEnv (concat (map classSelIds classes)) $ + tcExtendGlobalValEnv data_ids $ + tcExtendGlobalValEnv cls_ids $ -- Extend the TyCon envt with the tycons corresponding to - -- the classes, and the global value environment with the - -- corresponding data cons. + -- the classes. -- They are mentioned in types in interface files. - tcExtendGlobalValEnv (map (dataConId . classDataCon) classes) $ tcExtendTypeEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, ATyCon tycon)) | clas <- classes, let tycon = classTyCon clas @@ -230,7 +228,7 @@ tcModule rn_name_supply fixities -- Second pass over class and instance declarations, -- to compile the bindings themselves. tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> - tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) -> + tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> tcRules decls `thenNF_Tc` \ (lie_rules, rules) -> @@ -260,10 +258,11 @@ tcModule rn_name_supply fixities -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. let - all_binds = data_binds `AndMonoBinds` + all_binds = imp_data_binds `AndMonoBinds` + imp_cls_binds `AndMonoBinds` val_binds `AndMonoBinds` inst_binds `AndMonoBinds` - cls_binds `AndMonoBinds` + cls_dm_binds `AndMonoBinds` const_inst_binds `AndMonoBinds` foe_binds in diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 77a7acbd01..7974073912 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -35,7 +35,7 @@ import CmdLineOpts ( opt_IrrefutableTuples ) import DataCon ( DataCon, dataConSig, dataConFieldLabels, dataConSourceArity ) -import Id ( Id, idType, isDataConId_maybe ) +import Id ( Id, idType, isDataConWrapId_maybe ) import Type ( Type, isTauTy, mkTyConApp, mkClassPred, boxedTypeKind ) import Subst ( substTy, substClasses ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, @@ -394,7 +394,7 @@ tcOverloadedLitPat pat lit over_lit pat_ty tcConstructor pat con_name pat_ty = -- Check that it's a constructor tcLookupValue con_name `thenNF_Tc` \ con_id -> - case isDataConId_maybe con_id of { + case isDataConWrapId_maybe con_id of { Nothing -> failWithTc (badCon con_id); Just data_con -> diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 53fc6498a4..c5cdf0c45f 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -72,6 +72,17 @@ tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc) -- Gather the template variables and tyvars let tpl_ids = map instToId (bagToList lhs_dicts) ++ ids + + -- IMPORTANT! We *quantify* over any dicts that appear in the LHS + -- Reason: + -- a) The particular dictionary isn't important, because its value + -- depends only on the type + -- e.g gcd Int $fIntegralInt + -- Here we'd like to match against (gcd Int any_d) for any 'any_d' + -- + -- b) We'd like to make available the dictionaries bound + -- on the LHS in the RHS, so quantifying over them is good + -- See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS in -- Gather type variables to quantify over diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index f3a3c07a7b..b05225f0f0 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -255,7 +255,7 @@ tcSimplify str local_tvs wanted_lie -- We're infering (not checking) the type, and -- the inst constrains a local type variable - | isDict inst = DontReduce -- Dicts + | isDict inst = DontReduceUnlessConstant -- Dicts | otherwise = ReduceMe AddToIrreds -- Lits and Methods \end{code} @@ -405,7 +405,10 @@ data WhatToDo = ReduceMe -- Try to reduce this NoInstanceAction -- What to do if there's no such instance - | DontReduce -- Return as irreducible + | DontReduce -- Return as irreducible + + | DontReduceUnlessConstant -- Return as irreducible unless it can + -- be reduced to a constant in one step | Free -- Return as free @@ -652,7 +655,11 @@ reduce stack try_me wanted state@(avails, frees, irreds) ; - DontReduce -> -- It's irreducible (or at least should not be reduced) + + DontReduce -> add_to_irreds + ; + + DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced) -- See if the inst can be reduced to a constant in one step lookupInst wanted `thenNF_Tc` \ lookup_result -> case lookup_result of diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index d722a9c2c9..73282fe622 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -155,7 +155,7 @@ tcAddDeclCtxt decl thing_inside where (name, loc, thing) = case decl of - (ClassDecl _ name _ _ _ _ _ _ _ _ loc) -> (name, loc, "class") + (ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class") (TySynonym name _ _ loc) -> (name, loc, "type synonym") (TyData NewType _ name _ _ _ _ loc) -> (name, loc, "data type") (TyData DataType _ name _ _ _ _ loc) -> (name, loc, "newtype") @@ -206,7 +206,7 @@ getTyBinding1 (TyData _ _ name tyvars _ _ _ _) Nothing, ATyCon (error "ATyCon: data"))) -getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _ _) +getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _) = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds -> returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds, Just (length tyvars), @@ -271,7 +271,7 @@ Edges in Type/Class decls mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique]) -mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _) +mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _) = Just (decl, getUnique name, map (getUnique . get_clas) ctxt) mk_cls_edges other_decl = Nothing @@ -287,7 +287,7 @@ mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _) mk_edges decl@(TySynonym name _ rhs _) = (decl, getUnique name, uniqSetToList (get_ty rhs)) -mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _) +mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _ _) = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` get_sigs sigs)) @@ -304,7 +304,7 @@ get_deriv (Just clss) = unionManyUniqSets (map set_name clss) get_cons cons = unionManyUniqSets (map get_con cons) ---------------------------------------------------- -get_con (ConDecl _ _ ctxt details _) +get_con (ConDecl _ _ _ ctxt details _) = get_ctxt ctxt `unionUniqSets` get_con_details details ---------------------------------------------------- diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 1a3c2c3e63..78c6f320d9 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -7,7 +7,7 @@ module TcTyDecls ( tcTyDecl, kcTyDecl, tcConDecl, - mkDataBinds + mkImplicitDataBinds ) where #include "HsVersions.h" @@ -17,7 +17,7 @@ import HsSyn ( MonoBinds(..), andMonoBindList ) import RnHsSyn ( RenamedTyClDecl, RenamedConDecl ) -import TcHsSyn ( TcMonoBinds ) +import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) import BasicTypes ( RecFlag(..), NewOrData(..) ) import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope, @@ -31,11 +31,11 @@ import TcUnify ( unifyKind ) import Class ( Class ) import DataCon ( DataCon, dataConSig, mkDataCon, isNullaryDataCon, - dataConFieldLabels, dataConId, + dataConFieldLabels, dataConId, dataConWrapId, markedStrict, notMarkedStrict, markedUnboxed ) -import MkId ( mkDataConId, mkRecordSelId, mkNewTySelId ) -import Id ( getIdUnfolding ) +import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId ) +import Id ( idUnfolding ) import CoreUnfold ( unfoldingTemplate ) import FieldLabel import Var ( Id, TyVar ) @@ -78,7 +78,7 @@ kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ src_loc) mapTc kcConDecl con_decls `thenTc_` returnTc () -kcConDecl (ConDecl _ ex_tvs ex_ctxt details loc) +kcConDecl (ConDecl _ _ ex_tvs ex_ctxt details loc) = tcAddSrcLoc loc ( tcExtendTyVarScope ex_tvs ( \ tyvars -> tcContext ex_ctxt `thenTc_` @@ -167,14 +167,16 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ \begin{code} tcConDecl :: TyCon -> [TyVar] -> [(Class,[Type])] -> RenamedConDecl -> TcM s DataCon -tcConDecl tycon tyvars ctxt (ConDecl name ex_tvs ex_ctxt details src_loc) +tcConDecl tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc) = tcAddSrcLoc src_loc $ tcExtendTyVarScope ex_tvs $ \ ex_tyvars -> tcContext ex_ctxt `thenTc` \ ex_theta -> - let ex_ctxt' = classesOfPreds ex_theta in - tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_ctxt' details + let + ex_ctxt' = classesOfPreds ex_theta + in + tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_ctxt' details -tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details +tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_theta details = case details of VanillaCon btys -> tc_datacon btys InfixCon bty1 bty2 -> tc_datacon [bty1,bty2] @@ -231,8 +233,9 @@ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details tyvars (thinContext arg_tys ctxt) ex_tyvars' ex_theta' arg_tys - tycon data_con_id - data_con_id = mkDataConId data_con + tycon data_con_id data_con_wrap_id + data_con_id = mkDataConId wkr_name data_con + data_con_wrap_id = mkDataConWrapId data_con in returnNF_Tc data_con @@ -263,31 +266,32 @@ get_pty (Unpacked ty) = ty %************************************************************************ \begin{code} -mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds) -mkDataBinds [] = returnTc ([], EmptyMonoBinds) -mkDataBinds (tycon : tycons) - | isSynTyCon tycon = mkDataBinds tycons - | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) -> - mkDataBinds tycons `thenTc` \ (ids2, b2) -> +mkImplicitDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds) +mkImplicitDataBinds [] = returnTc ([], EmptyMonoBinds) +mkImplicitDataBinds (tycon : tycons) + | isSynTyCon tycon = mkImplicitDataBinds tycons + | otherwise = mkImplicitDataBinds_one tycon `thenTc` \ (ids1, b1) -> + mkImplicitDataBinds tycons `thenTc` \ (ids2, b2) -> returnTc (ids1++ids2, b1 `AndMonoBinds` b2) -mkDataBinds_one tycon +mkImplicitDataBinds_one tycon = mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids -> let - data_ids = map dataConId data_cons ++ sel_ids + unf_ids = sel_ids ++ data_con_wrapper_ids + all_ids = map dataConId data_cons ++ unf_ids -- For the locally-defined things - -- we need to turn the unfoldings inside the Ids into bindings, - binds | isLocallyDefined tycon - = [ CoreMonoBind data_id (unfoldingTemplate (getIdUnfolding data_id)) - | data_id <- data_ids, isLocallyDefined data_id - ] - | otherwise - = [] + -- we need to turn the unfoldings inside the selector Ids into bindings, + -- and build bindigns for the constructor wrappers + binds | isLocallyDefined tycon = idsToMonoBinds unf_ids + | otherwise = EmptyMonoBinds in - returnTc (data_ids, andMonoBindList binds) + returnTc (all_ids, binds) where data_cons = tyConDataCons tycon + + data_con_wrapper_ids = map dataConWrapId data_cons + fields = [ (con, field) | con <- data_cons, field <- dataConFieldLabels con ] @@ -307,25 +311,11 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) -- data type use the same type variables = checkTc (all (== field_ty) other_tys) (fieldTypeMisMatch field_name) `thenTc_` - returnTc selector_id + returnTc (mkRecordSelId tycon first_field_label) where field_ty = fieldLabelType first_field_label field_name = fieldLabelName first_field_label other_tys = [fieldLabelType fl | (_, fl) <- other_fields] - (tyvars, _, _, _, _, _) = dataConSig first_con - data_ty = mkTyConApp tycon (mkTyVarTys tyvars) - -- tyvars of first_con may be free in field_ty - -- Now build the selector - - selector_ty :: Type - selector_ty = mkForAllTys tyvars $ - mkFunTy data_ty $ - field_ty - - selector_id :: Id - selector_id - | isNewTyCon tycon = mkNewTySelId first_field_label selector_ty - | otherwise = mkRecordSelId first_field_label selector_ty \end{code} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index db54a7da60..8d0d675569 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -242,7 +242,7 @@ ppr_dict env ctxt (clas, tys) = ppr clas <+> \end{code} \begin{code} -pprTyEnv = initPprEnv b b (Just ppr) b (Just (\site -> pprTyVarBndr)) b +pprTyEnv = initPprEnv b (Just ppr) b (Just (\site -> pprTyVarBndr)) b where b = panic "PprType:init_ppr_env" \end{code} diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 14180b2203..6c6efafebd 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -10,6 +10,7 @@ module TyCon( isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, + isRecursiveTyCon, mkAlgTyCon, mkFunTyCon, @@ -276,17 +277,16 @@ isDataTyCon other = False isNewTyCon (AlgTyCon {algTyConFlavour = NewType}) = True isNewTyCon other = False --- A "product" tycon is --- non-recursive --- has one constructor, +-- A "product" tycon +-- has *one* constructor, -- is *not* existential --- is *not* an unboxed tuple --- whether DataType or NewType -isProductTyCon (AlgTyCon {dataCons = [data_con], algTyConRec = NonRecursive}) - = not (isExistentialDataCon data_con) -isProductTyCon (TupleTyCon { tyConBoxed = boxed }) - = boxed -isProductTyCon other = False +-- but +-- may be DataType or NewType, +-- may be unboxed or not, +-- may be recursive or not +isProductTyCon (AlgTyCon {dataCons = [data_con]}) = not (isExistentialDataCon data_con) +isProductTyCon (TupleTyCon {}) = True +isProductTyCon other = False isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False @@ -300,6 +300,9 @@ isTupleTyCon other = False isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = False}) = True isUnboxedTupleTyCon other = False + +isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True +isRecursiveTyCon other = False \end{code} \begin{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index cba55fbcb6..33d59baccc 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -29,14 +29,16 @@ module Type ( mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, - mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, splitFunTysN, + mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN, funResultTy, funArgTy, zipFunTys, mkTyConApp, mkTyConTy, splitTyConApp_maybe, splitAlgTyConApp_maybe, splitAlgTyConApp, mkDictTy, mkPredTy, splitPredTy_maybe, splitDictTy_maybe, isDictTy, - mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe, + mkSynTy, isSynTy, deNoteType, + + repType, splitRepFunTys, splitNewType_maybe, typePrimRep, UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg, mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, @@ -52,7 +54,6 @@ module Type ( -- Lifting and boxity isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType, - typePrimRep, -- Free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, @@ -78,12 +79,12 @@ import TypeRep -- Other imports: -import {-# SOURCE #-} DataCon( DataCon, dataConType ) +import {-# SOURCE #-} DataCon( DataCon, dataConRepType ) import {-# SOURCE #-} PprType( pprType, pprPred ) -- Only called in debug messages import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy ) -- friends: -import Var ( TyVar, IdOrTyVar, UVar, +import Var ( TyVar, Var, UVar, tyVarKind, tyVarName, setTyVarName, isId, idType, ) import VarEnv @@ -235,6 +236,10 @@ mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr FunTy ty tys +splitFunTy :: Type -> (Type, Type) +splitFunTy (FunTy arg res) = (arg, res) +splitFunTy (NoteTy _ ty) = splitFunTy ty + splitFunTy_maybe :: Type -> Maybe (Type, Type) splitFunTy_maybe (FunTy arg res) = Just (arg, res) splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty @@ -418,6 +423,8 @@ The reason is that we then get better (shorter) type signatures in interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. + Representation types + ~~~~~~~~~~~~~~~~~~~~ repType looks through (a) for-alls, and @@ -432,6 +439,12 @@ repType (ForAllTy _ ty) = repType ty repType (TyConApp tc tys) | isNewTyCon tc = repType (new_type_rep tc tys) repType other_ty = other_ty + +typePrimRep :: Type -> PrimRep +typePrimRep ty = case splitTyConApp_maybe (repType ty) of + Just (tc, ty_args) -> tyConPrimRep tc + other -> PtrRep + splitNewType_maybe :: Type -> Maybe Type -- Find the representation of a newtype, if it is one -- Looks through multiple levels of newtype @@ -449,8 +462,15 @@ new_type_rep :: TyCon -> [Type] -> Type -- Looks through one layer only new_type_rep tc tys = ASSERT( isNewTyCon tc ) - case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of + case splitFunTy_maybe (applyTys (dataConRepType (head (tyConDataCons tc))) tys) of Just (rep_ty, _) -> rep_ty + +splitRepFunTys :: Type -> ([Type], Type) +-- Like splitFunTys, but looks through newtypes and for-alls +splitRepFunTys ty = split [] (repType ty) + where + split args (FunTy arg res) = split (arg:args) (repType res) + split args ty = (reverse args, ty) \end{code} @@ -609,7 +629,7 @@ splitForAllTys ty = case splitUsgTy_maybe ty of it is given a type variable or a term variable. \begin{code} -mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work... +mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work... mkPiType v ty | isId v = mkFunTy (idType v) ty | otherwise = mkForAllTy v ty \end{code} @@ -941,11 +961,6 @@ isNewType ty = case splitTyConApp_maybe ty of Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) isNewTyCon tc other -> False - -typePrimRep :: Type -> PrimRep -typePrimRep ty = case splitTyConApp_maybe (repType ty) of - Just (tc, ty_args) -> tyConPrimRep tc - other -> PtrRep \end{code} diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs index e3b34eb60c..52f5d0873d 100644 --- a/ghc/compiler/types/Variance.lhs +++ b/ghc/compiler/types/Variance.lhs @@ -15,7 +15,7 @@ import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( mkDictTy ) import TyCon ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataCons, tyConTyVars, tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon ) -import DataCon ( dataConRawArgTys, dataConSig ) +import DataCon ( dataConRepArgTys ) import FiniteMap import Var ( TyVar ) @@ -78,14 +78,12 @@ calcTyConArgVrcs tycons tcaoIter oi tc | isAlgTyCon tc = let cs = tyConDataCons tc vs = tyConTyVars tc - argtys = concatMap dataConRawArgTys cs - exdicttys = concatMap ((\ (_,_,_,exth,_,_) -> map (uncurry mkDictTy) exth) - . dataConSig) cs + argtys = concatMap dataConRepArgTys cs myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $ tyConArgVrcs_maybe tc) tc -- we use the already-computed result for tycons not in this SCC - in map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) (exdicttys ++ argtys)) + in map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys) vs tcaoIter oi tc | isSynTyCon tc diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs index 2b6944827a..60faf60226 100644 --- a/ghc/compiler/usageSP/UsageSPInf.lhs +++ b/ghc/compiler/usageSP/UsageSPInf.lhs @@ -26,8 +26,7 @@ import Type ( UsageAnn(..), splitUsForAllTys, substUsTy, mkFunTy, mkForAllTy ) import TyCon ( tyConArgVrcs_maybe, isFunTyCon ) -import DataCon ( dataConType ) -import Const ( Con(..), Literal(..), literalType ) +import Literal ( Literal(..), literalType ) import Var ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo ) import IdInfo ( setLBVarInfo, LBVarInfo(..) ) import Id ( mayHaveNoBinding, isExportedId ) @@ -222,17 +221,16 @@ usgInfCE ve e0@(Var v) | isTyVar v emptyUConSet, unitMS v') -usgInfCE ve e0@(Con (Literal lit) args) - = ASSERT( null args ) - do u1 <- newVarUSMM (Left e0) +usgInfCE ve e0@(Lit lit) + = do u1 <- newVarUSMM (Left e0) return (e0, mkUsgTy u1 (literalType lit), emptyUConSet, emptyMS) -usgInfCE ve (Con DEFAULT _) - = panic "usgInfCE: DEFAULT" - +{- ------------------------------------ + No Con form now; we rely on usage information in the constructor itself + usgInfCE ve e0@(Con con args) = -- constant or primop. guaranteed saturated. do let (ey1s,e1s) = span isTypeArg args @@ -252,7 +250,7 @@ usgInfCE ve e0@(Con con args) unionUCSs (h3s ++ h4s), foldl plusMS emptyMS f3s) - where dataConTys c u y1s + whered ataConTys c u y1s -- compute argtys of a datacon = let cTy = annotMany (dataConType c) -- extra (sigma) annots later replaced (y2us,y2u) = splitFunTys (applyTys cTy y1s) @@ -260,6 +258,8 @@ usgInfCE ve e0@(Con con args) -- not an arrow type. reUsg = mkUsgTy u . unUsgTy in (map reUsg y2us, reUsg y2u) +-------------------------------------------- -} + usgInfCE ve e0@(App ea (Type yb)) = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea diff --git a/ghc/compiler/usageSP/UsageSPLint.lhs b/ghc/compiler/usageSP/UsageSPLint.lhs index ae2436ef3d..7d6f5e0000 100644 --- a/ghc/compiler/usageSP/UsageSPLint.lhs +++ b/ghc/compiler/usageSP/UsageSPLint.lhs @@ -22,8 +22,9 @@ import CoreSyn import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( UsageAnn(..), isUsgTy, tyUsg ) import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon ) -import Var ( IdOrTyVar, varType, idInfo ) -import IdInfo ( LBVarInfo(..), lbvarInfo ) +import Var ( Var, varType ) +import Id ( idLBVarInfo ) +import IdInfo ( LBVarInfo(..) ) import SrcLoc ( noSrcLoc ) import ErrUtils ( Message, ghcExit ) import Util ( zipWithEqual ) @@ -265,9 +266,9 @@ already since they are imported and not changeable. First, the various kinds of worsenings we can have: \begin{code} -data WorseErr = WorseVar IdOrTyVar IdOrTyVar -- variable gets worse +data WorseErr = WorseVar Var Var -- variable gets worse | WorseTerm CoreExpr CoreExpr -- term gets worse - | WorseLam IdOrTyVar IdOrTyVar -- lambda gets worse + | WorseLam Var Var -- lambda gets worse instance Outputable WorseErr where ppr (WorseVar v0 v) = ptext SLIT("Identifier:") <+> ppr v0 <+> dcolon @@ -313,10 +314,7 @@ checkBind _ _ = panic "UsageSPLint.checkBind" checkCE :: CoreExpr -> CoreExpr -> Bag WorseErr checkCE (Var _) (Var _) = emptyBag - -checkCE (Con _ args) (Con _ args') = unionManyBags $ - zipWithEqual "UsageSPLint.checkCE:Con" - checkCE args args' +checkCE (Lit _) (Lit _) = emptyBag checkCE (App e arg) (App e' arg') = (checkCE e e') `unionBags` (checkCE arg arg') @@ -358,7 +356,7 @@ checkCE t t' = pprPanic "usageSPLint.che -- does binder change from Once to Many? -- notice we only check the top-level annotation; this is all that's necessary. KSW 1999-04. -checkVar :: IdOrTyVar -> IdOrTyVar -> Bag WorseErr +checkVar :: Var -> Var -> Bag WorseErr checkVar v v' | isTyVar v = emptyBag | not (isUsgTy y) = emptyBag -- if initially no annot, definitely OK | otherwise = checkUsg u u' (WorseVar v v') @@ -368,9 +366,9 @@ checkVar v v' | isTyVar v = emptyBag u' = tyUsg y' -- does lambda change from Once to Many? -checkLamVar :: IdOrTyVar -> IdOrTyVar -> Bag WorseErr +checkLamVar :: Var -> Var -> Bag WorseErr checkLamVar v v' | isTyVar v = emptyBag - | otherwise = case ((lbvarInfo . idInfo) v, (lbvarInfo . idInfo) v') of + | otherwise = case (idLBVarInfo v, idLBVarInfo v') of (NoLBVarInfo , _ ) -> emptyBag (IsOneShotLambda, IsOneShotLambda) -> emptyBag (IsOneShotLambda, NoLBVarInfo ) -> unitBag (WorseLam v v') diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs index fd91ec217e..c45f83e304 100644 --- a/ghc/compiler/usageSP/UsageSPUtils.lhs +++ b/ghc/compiler/usageSP/UsageSPUtils.lhs @@ -25,8 +25,8 @@ module UsageSPUtils ( AnnotM(AnnotM), initAnnotM, #include "HsVersions.h" import CoreSyn -import Const ( Con(..), Literal(..) ) -import Var ( IdOrTyVar, varName, varType, setVarType, mkUVar ) +import Literal ( Literal(..) ) +import Var ( Var, varName, varType, setVarType, mkUVar ) import Id ( mayHaveNoBinding, isExportedId ) import Name ( isLocallyDefined ) import TypeRep ( Type(..), TyNote(..) ) -- friend @@ -180,11 +180,11 @@ usage info in its type that must at all costs be preserved. This is assumed true (exactly) of all imported ids. \begin{code} -hasLocalDef :: IdOrTyVar -> Bool +hasLocalDef :: Var -> Bool hasLocalDef var = isLocallyDefined var && not (mayHaveNoBinding var) -hasUsgInfo :: IdOrTyVar -> Bool +hasUsgInfo :: Var -> Bool hasUsgInfo var = (not . isLocallyDefined) var \end{code} @@ -209,8 +209,8 @@ genAnnotBind :: (MungeFlags -> Type -> AnnotM flexi Type) -- type-altering func -> CoreBind -- original CoreBind -> AnnotM flexi (CoreBind, -- annotated CoreBind - [IdOrTyVar], -- old variables, to be mapped to... - [IdOrTyVar]) -- ... new variables + [Var], -- old variables, to be mapped to... + [Var]) -- ... new variables genAnnotBind f g (NonRec v1 e1) = do { v1' <- genAnnotVar f v1 ; e1' <- genAnnotCE f g e1 @@ -230,7 +230,7 @@ genAnnotCE :: (MungeFlags -> Type -> AnnotM flexi Type) -- type-altering functi -> AnnotM flexi CoreExpr -- yields new expression genAnnotCE mungeType mungeTerm = go - where go e0@(Var v) | isTyVar v = return e0 -- arises, e.g., as tyargs of Con + where go e0@(Var v) | isTyVar v = return e0 -- arises, e.g., as tyargs of constructor -- (no it doesn't: (Type (TyVar tyvar)) | otherwise = do { mv' <- lookupAnnVar v ; v' <- case mv' of @@ -239,10 +239,8 @@ genAnnotCE mungeType mungeTerm = go ; return (Var v') } - go (Con c args) = -- we know it's saturated - do { args' <- mapM go args - ; return (Con c args') - } + go (Lit l) = -- we know it's saturated + return (Lit l) go (App e arg) = do { e' <- go e ; arg' <- go arg @@ -320,8 +318,8 @@ genAnnotCE mungeType mungeTerm = go genAnnotVar :: (MungeFlags -> Type -> AnnotM flexi Type) - -> IdOrTyVar - -> AnnotM flexi IdOrTyVar + -> Var + -> AnnotM flexi Var genAnnotVar mungeType v | isTyVar v = return v | otherwise = do { vty' <- mungeType (sigVarTyMF v) (varType v) @@ -551,8 +549,8 @@ variable mapping, along with some general state. \begin{code} newtype AnnotM flexi a = AnnotM ( flexi -- UniqSupply etc - -> VarEnv IdOrTyVar -- unannotated to annotated variables - -> (a,flexi,VarEnv IdOrTyVar)) + -> VarEnv Var -- unannotated to annotated variables + -> (a,flexi,VarEnv Var)) unAnnotM (AnnotM f) = f instance Monad (AnnotM flexi) where @@ -563,17 +561,17 @@ instance Monad (AnnotM flexi) where initAnnotM :: fl -> AnnotM fl a -> (a,fl) initAnnotM fl m = case (unAnnotM m) fl emptyVarEnv of { (r,fl',_) -> (r,fl') } -withAnnVar :: IdOrTyVar -> IdOrTyVar -> AnnotM fl a -> AnnotM fl a +withAnnVar :: Var -> Var -> AnnotM fl a -> AnnotM fl a withAnnVar v v' m = AnnotM (\ us ve -> let ve' = extendVarEnv ve v v' (r,us',_) = (unAnnotM m) us ve' in (r,us',ve)) -withAnnVars :: [IdOrTyVar] -> [IdOrTyVar] -> AnnotM fl a -> AnnotM fl a +withAnnVars :: [Var] -> [Var] -> AnnotM fl a -> AnnotM fl a withAnnVars vs vs' m = AnnotM (\ us ve -> let ve' = plusVarEnv ve (zipVarEnv vs vs') (r,us',_) = (unAnnotM m) us ve' in (r,us',ve)) -lookupAnnVar :: IdOrTyVar -> AnnotM fl (Maybe IdOrTyVar) +lookupAnnVar :: Var -> AnnotM fl (Maybe Var) lookupAnnVar var = AnnotM (\ us ve -> (lookupVarEnv ve var, us, ve)) @@ -602,8 +600,7 @@ newVarUs e = getUniqueUs `thenUs` \ u -> returnUs (UsVar uv) {- #ifdef DEBUG let src = case e of - Left (Con (Literal _) _) -> "literal" - Left (Con _ _) -> "primop" + Left (Lit _) -> "literal" Left (Lam v e) -> "lambda: " ++ showSDoc (ppr v) Left _ -> "unknown" Right s -> s diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs index 2f6118fc91..6dd9251e66 100644 --- a/ghc/compiler/utils/Maybes.lhs +++ b/ghc/compiler/utils/Maybes.lhs @@ -5,7 +5,7 @@ \begin{code} module Maybes ( --- Maybe(..), -- no, it's in 1.3 + Maybe2(..), Maybe3(..), MaybeErr(..), orElse, @@ -38,6 +38,18 @@ infixr 4 `orElse` %************************************************************************ %* * +\subsection[Maybe2,3 types]{The @Maybe2@ and @Maybe3@ types} +%* * +%************************************************************************ + +\begin{code} +data Maybe2 a b = Just2 a b | Nothing2 deriving (Eq,Show) +data Maybe3 a b c = Just3 a b c | Nothing3 deriving (Eq,Show) +\end{code} + + +%************************************************************************ +%* * \subsection[Maybe type]{The @Maybe@ type} %* * %************************************************************************ @@ -173,3 +185,4 @@ returnMaB v = Succeeded v failMaB :: err -> MaybeErr val err failMaB e = Failed e \end{code} + diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 42b1ba3a27..586f44eb73 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -155,13 +155,13 @@ printSDoc d sty = printDoc PageMode stdout (d sty) -- I'm not sure whether the direct-IO approach of printDoc -- above is better or worse than the put-big-string approach here printErrs :: SDoc -> IO () -printErrs doc = printDoc PageMode stderr (final_doc user_style) +printErrs doc = printDoc PageMode stdout (final_doc user_style) where final_doc = doc -- $$ text "" user_style = mkUserStyle (PartWay opt_PprUserLength) printDump :: SDoc -> IO () -printDump doc = printForUser stderr (doc $$ text "") +printDump doc = printForUser stdout (doc $$ text "") -- We used to always print in debug style, but I want -- to try the effect of a more user-ish style (unless you -- say -dppr-debug diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 1f7289d2ae..8e2198b050 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -15,12 +15,15 @@ module Util ( -- general list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, - zipLazy, stretchZipEqual, + zipLazy, stretchZipWith, mapAndUnzip, mapAndUnzip3, nOfThem, lengthExceeds, isSingleton, only, snocView, isIn, isn'tIn, + -- for-loop + nTimes, + -- association lists assoc, assocUsing, assocDefault, assocDefaultUsing, @@ -104,6 +107,21 @@ mapEager f (x:xs) = f x `thenEager` \ y -> %************************************************************************ %* * +\subsection{A for loop} +%* * +%************************************************************************ + +\begin{code} +-- Compose a function with itself n times. (nth rather than twice) +nTimes :: Int -> (a -> a) -> (a -> a) +nTimes 0 _ = id +nTimes 1 f = f +nTimes n f = f . nTimes (n-1) f +\end{code} + + +%************************************************************************ +%* * \subsection[Utils-lists]{General list processing} %* * %************************************************************************ @@ -154,13 +172,16 @@ zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys \begin{code} -stretchZipEqual :: (a -> b -> Maybe a) -> [a] -> [b] -> [a] --- (stretchZipEqual f xs ys) stretches ys to "fit" the places where f returns a Just +stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] +-- (stretchZipWith p z f xs ys) stretches ys by inserting z in +-- the places where p returns *True* -stretchZipEqual f [] [] = [] -stretchZipEqual f (x:xs) (y:ys) = case f x y of - Just x' -> x' : stretchZipEqual f xs ys - Nothing -> x : stretchZipEqual f xs (y:ys) +stretchZipWith p z f [] ys = [] +stretchZipWith p z f (x:xs) ys + | p x = f x z : stretchZipWith p z f xs ys + | otherwise = case ys of + [] -> [] + (y:ys) -> f x y : stretchZipWith p z f xs ys \end{code} diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index d8a101ad1a..77c505d997 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -495,7 +495,7 @@ $Osuffix = ''; # default: use the normal suffix for that kind of output $HiSuffix = 'hi'; $HiSuffix_prelude = ''; $CompilingPrelude=0; -$Do_recomp_chkr = 0; # don't use the recompilatio checker unless asked +$Do_recomp_chkr = 1; # Use the recompilation checker by default $Do_cc = -1; # a MAGIC indeterminate value; will be set to 1 or 0. $Do_as = 1; @@ -726,25 +726,18 @@ sub setupOptimiseFlags { '-fno-rules', # Similarly, don't apply any rules until after full laziness # Notably, list fusion can prevent floating. + '-fno-case-of-case', # Don't do case-of-case transformations. + # This makes full laziness work better + '-fmax-simplifier-iterations2', ']', # Specialisation is best done before full laziness # so that overloaded functions have all their dictionary lambdas manifest ($Oopt_DoSpecialise) ? ( $Oopt_DoSpecialise, ) : (), - '-ffull-laziness', + '-ffloat-outwards', '-ffloat-inwards', -# '-fsimplify', -# '[', -# # Run the simplifier before specialising, so that overloaded functions -# # look like f = \d -> ... -# # (Full laziness may lift out something hiding the \d -# '-finline-phase1', -# '-fmax-simplifier-iterations1', -# ']', - - '-fsimplify', '[', '-finline-phase1', @@ -766,10 +759,17 @@ sub setupOptimiseFlags { # before strictness analysis runs '-finline-phase2', - $Oopt_MaxSimplifierIterations, + '-fmax-simplifier-iterations2', ']', + '-fsimplify', + '[', + '-fmax-simplifier-iterations2', + # No -finline-phase: allow all Ids to be inlined now + # This gets foldr inlined before strictness analysis + ']', + '-fstrictness', '-fcpr-analyse', '-fworker-wrapper', @@ -780,12 +780,19 @@ sub setupOptimiseFlags { # No -finline-phase: allow all Ids to be inlined now ']', - '-ffull-laziness', # nofib/spectral/hartel/wang doubles in speed if you + '-ffloat-outwards', # nofib/spectral/hartel/wang doubles in speed if you # do full laziness late in the day. It only happens # after fusion and other stuff, so the early pass doesn't # catch it. For the record, the redex is # f_el22 (f_el21 r_midblock) +# Leave out lambda lifting for now +# '-fsimplify', # Tidy up results of full laziness +# '[', +# '-fmax-simplifier-iterations2', +# ']', +# '-ffloat-outwards-full', + # We want CSE to follow the final full-laziness pass, because it may # succeed in commoning up things floated out by full laziness. # @@ -1096,14 +1103,14 @@ sub setupLinkOpts { ,'-u', "${uscore}PrelAddr_I64zh_con_info" ,'-u', "${uscore}PrelAddr_W64zh_con_info" ,'-u', "${uscore}PrelStable_StablePtr_con_info" - ,'-u', "${uscore}PrelBase_False_static_closure" - ,'-u', "${uscore}PrelBase_True_static_closure" + ,'-u', "${uscore}PrelBase_False_closure" + ,'-u', "${uscore}PrelBase_True_closure" ,'-u', "${uscore}PrelPack_unpackCString_closure" ,'-u', "${uscore}PrelException_stackOverflow_closure" ,'-u', "${uscore}PrelException_heapOverflow_closure" - ,'-u', "${uscore}PrelException_NonTermination_static_closure" - ,'-u', "${uscore}PrelException_PutFullMVar_static_closure" - ,'-u', "${uscore}PrelException_BlockedOnDeadMVar_static_closure" + ,'-u', "${uscore}PrelException_NonTermination_closure" + ,'-u', "${uscore}PrelException_PutFullMVar_closure" + ,'-u', "${uscore}PrelException_BlockedOnDeadMVar_closure" ,'-u', "${uscore}__init_Prelude" ,'-u', "${uscore}__init_PrelMain" )); @@ -1668,23 +1675,12 @@ sub runHscAndProcessInterfaces { # Tell the C compiler and assembler not to run $do_cc = 0; $do_as = 0; - # Update dependency info, touch both object file and - # interface file, so that the following invariant is - # maintained: - # - # a dependent module's interface file should after recompilation - # checking be newer than the interface files of its imports. - # - # That is, if module A's interface file changes, then module B - # (which import from A) needs to be checked. - # If A's change does not affect B, which causes the compiler to bail - # out early, we still need to touch the interface file of B. The reason - # for this is that B may export A's interface. + # Update dependency info, by touching the object file + # This records in the file system that the work of + # recompiling this module has been done # &run_something("touch $ofile_target", "Touch $ofile_target, to propagate dependencies") if $HscOut ne '-N='; - &run_something("touch $hifile_target", - "Touch $hifile_target, to propagate dependencies") if $ProduceHi =~ /-nohifile=/ ; } else { @@ -3218,8 +3214,8 @@ arg: while($_ = $Args[0]) { # --------------- - /^-fasm-(.*)$/ && do { $HscOut = '-S='; next arg; }; # force using nativeGen - /^-fvia-[cC]$/ && do { $HscOut = '-C='; next arg; }; # force using C compiler + /^-fasm-(.*)$/ && do { $HscOut = '-S='; next arg; }; # force using nativeGen + /^-fvia-[cC]$/ && do { $HscOut = '-C='; next arg; }; # force using C compiler # --------------- diff --git a/ghc/includes/Prelude.h b/ghc/includes/Prelude.h index 2f8d93d202..ddac99e94d 100644 --- a/ghc/includes/Prelude.h +++ b/ghc/includes/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Prelude.h,v 1.10 1999/12/20 10:34:33 simonpj Exp $ + * $Id: Prelude.h,v 1.11 2000/03/23 17:45:31 simonpj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -13,14 +13,14 @@ #ifdef COMPILING_RTS #ifdef COMPILER -extern DLL_IMPORT const StgClosure PrelBase_Z91Z93_static_closure; -extern DLL_IMPORT const StgClosure PrelBase_Z40Z41_static_closure; -extern DLL_IMPORT const StgClosure PrelBase_True_static_closure; -extern DLL_IMPORT const StgClosure PrelBase_False_static_closure; +extern DLL_IMPORT const StgClosure PrelBase_Z91Z93_closure; +extern DLL_IMPORT const StgClosure PrelBase_Z40Z41_closure; +extern DLL_IMPORT const StgClosure PrelBase_True_closure; +extern DLL_IMPORT const StgClosure PrelBase_False_closure; extern DLL_IMPORT const StgClosure PrelPack_unpackCString_closure; extern DLL_IMPORT const StgClosure PrelException_stackOverflow_closure; extern DLL_IMPORT const StgClosure PrelException_heapOverflow_closure; -extern DLL_IMPORT const StgClosure PrelException_NonTermination_static_closure; +extern DLL_IMPORT const StgClosure PrelException_NonTermination_closure; extern const StgClosure PrelMain_mainIO_closure; extern DLL_IMPORT const StgInfoTable PrelBase_Czh_static_info; @@ -44,13 +44,13 @@ extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info; * module these names are defined in. */ -#define Nil_closure PrelBase_ZMZN_static_closure -#define Unit_closure PrelBase_Z0T_static_closure -#define True_closure PrelBase_True_static_closure -#define False_closure PrelBase_False_static_closure +#define Nil_closure PrelBase_ZMZN_closure +#define Unit_closure PrelBase_Z0T_closure +#define True_closure PrelBase_True_closure +#define False_closure PrelBase_False_closure #define stackOverflow_closure PrelException_stackOverflow_closure #define heapOverflow_closure PrelException_heapOverflow_closure -#define NonTermination_closure PrelException_NonTermination_static_closure +#define NonTermination_closure PrelException_NonTermination_closure #define Czh_static_info PrelBase_Czh_static_info #define Izh_static_info PrelBase_Izh_static_info #define Fzh_static_info PrelFloat_Fzh_static_info diff --git a/ghc/includes/Regs.h b/ghc/includes/Regs.h index 579382b31f..4c2f911eb5 100644 --- a/ghc/includes/Regs.h +++ b/ghc/includes/Regs.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Regs.h,v 1.8 2000/01/12 15:15:17 simonmar Exp $ + * $Id: Regs.h,v 1.9 2000/03/23 17:45:31 simonpj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -610,6 +610,8 @@ GLOBAL_REG_DECL(bdescr *,SparkLim,REG_SparkLim) CALLER_SAVE_D2 \ CALLER_SAVE_L1 + /* Save Base last, since the others may + be addressed relative to it */ #define CALLER_SAVE_SYSTEM \ CALLER_SAVE_Sp \ CALLER_SAVE_Su \ @@ -621,7 +623,8 @@ GLOBAL_REG_DECL(bdescr *,SparkLim,REG_SparkLim) CALLER_SAVE_SparkHd \ CALLER_SAVE_SparkTl \ CALLER_SAVE_SparkBase \ - CALLER_SAVE_SparkLim + CALLER_SAVE_SparkLim \ + CALLER_SAVE_Base #define CALLER_RESTORE_USER \ CALLER_RESTORE_R1 \ @@ -640,6 +643,8 @@ GLOBAL_REG_DECL(bdescr *,SparkLim,REG_SparkLim) CALLER_RESTORE_D2 \ CALLER_RESTORE_L1 + /* Restore Base first, since the others may + be addressed relative to it */ #define CALLER_RESTORE_SYSTEM \ CALLER_RESTORE_Base \ CALLER_RESTORE_Sp \ diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index 84b7a9ccaf..4934e7f57c 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -98,6 +98,42 @@ default () -- Double isn't available yet %********************************************************* %* * +\subsection{DEBUGGING STUFF} +%* (for use when compiling PrelBase itself doesn't work) +%* * +%********************************************************* + +\begin{code} +{- +data Bool = False | True +data Ordering = LT | EQ | GT +data Char = C# Char# +type String = [Char] +data Int = I# Int# +data () = () +-- data [] a = MkNil + +not True = False +(&&) True True = True +otherwise = True + +build = error "urk" +foldr = error "urk" + +unpackCString# :: Addr# -> [Char] +unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a +unpackAppendCString# :: Addr# -> [Char] -> [Char] +unpackNBytes# :: Addr# -> Int# -> [Char] +unpackNBytes# a b = error "urk" +unpackCString# a = error "urk" +unpackFoldrCString# a = error "urk" +unpackAppendCString# a = error "urk" +-} +\end{code} + + +%********************************************************* +%* * \subsection{Standard classes @Eq@, @Ord@} %* * %********************************************************* @@ -106,8 +142,11 @@ default () -- Double isn't available yet class Eq a where (==), (/=) :: a -> a -> Bool - x /= y = not (x == y) - x == y = not (x /= y) +-- x /= y = not (x == y) +-- x == y = not (x /= y) +-- x /= y = True + (/=) x y = not ((==) x y) + x == y = True class (Eq a) => Ord a where compare :: a -> a -> Ordering @@ -166,8 +205,11 @@ class Monad m where data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) -- to avoid weird names like con2tag_[]# + instance (Eq a) => Eq [a] where +{- {-# SPECIALISE instance Eq [Char] #-} +-} [] == [] = True (x:xs) == (y:ys) = x == y && xs == ys _xs == _ys = False @@ -175,7 +217,9 @@ instance (Eq a) => Eq [a] where xs /= ys = if (xs == ys) then False else True instance (Ord a) => Ord [a] where +{- {-# SPECIALISE instance Ord [Char] #-} +-} a < b = case compare a b of { LT -> True; EQ -> False; GT -> False } a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False } a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True } @@ -262,8 +306,7 @@ augment g xs = g (:) xs \begin{code} map :: (a -> b) -> [a] -> [b] -{-# INLINE map #-} -map f xs = build (\c n -> foldr (mapFB c f) n xs) +map = mapList -- Note eta expanded mapFB c f x ys = c (f x) ys @@ -273,6 +316,7 @@ mapList _ [] = [] mapList f (x:xs) = f x : mapList f xs {-# RULES +"map" forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs) "mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g) "mapList" forall f. foldr (mapFB (:) f) [] = mapList f #-} @@ -284,8 +328,11 @@ mapList f (x:xs) = f x : mapList f xs ---------------------------------------------- \begin{code} (++) :: [a] -> [a] -> [a] -{-# INLINE (++) #-} -xs ++ ys = augment (\c n -> foldr c n xs) ys +(++) = append + +{-# RULES + "++" forall xs ys. (++) xs ys = augment (\c n -> foldr c n xs) ys + #-} append :: [a] -> [a] -> [a] append [] ys = ys @@ -566,8 +613,7 @@ unpacking the strings of error messages. \begin{code} unpackCString# :: Addr# -> [Char] -{-# INLINE unpackCString# #-} -unpackCString# a = build (unpackFoldrCString# a) +unpackCString# a = unpackCStringList# a unpackCStringList# :: Addr# -> [Char] unpackCStringList# addr @@ -614,6 +660,7 @@ unpackNBytes# addr len# = unpack [] (len# -# 1#) ch -> unpack (C# ch : acc) (i# -# 1#) {-# RULES +"unpack" forall a . unpackCString# a = build (unpackFoldrCString# a) "unpack-list" forall a . unpackFoldrCString# a (:) [] = unpackCStringList# a "unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n @@ -621,4 +668,5 @@ unpackNBytes# addr len# = unpack [] (len# -# 1#) -- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n #-} + \end{code} diff --git a/ghc/lib/std/PrelByteArr.lhs b/ghc/lib/std/PrelByteArr.lhs index 3973c741c1..ff44fb79cb 100644 --- a/ghc/lib/std/PrelByteArr.lhs +++ b/ghc/lib/std/PrelByteArr.lhs @@ -32,8 +32,12 @@ import PrelGHC data Ix ix => ByteArray ix = ByteArray ix ix ByteArray# data Ix ix => MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) -instance CCallable (MutableByteArray s ix) instance CCallable (ByteArray ix) +instance CCallable (MutableByteArray RealWorld ix) + -- Note the RealWorld! You can only ccall with MutableByteArray args + -- which are in the real world. When this was missed out, the result + -- was that a CCallOpId had a free tyvar, and since the compiler doesn't + -- expect that it didn't get zonked or substituted. Bad news. instance Eq (MutableByteArray s ix) where MutableByteArray _ _ arr1# == MutableByteArray _ _ arr2# diff --git a/ghc/lib/std/PrelEnum.lhs b/ghc/lib/std/PrelEnum.lhs index 2b0f5bd5af..f4d37eea77 100644 --- a/ghc/lib/std/PrelEnum.lhs +++ b/ghc/lib/std/PrelEnum.lhs @@ -191,17 +191,32 @@ instance Enum Char where fromEnum = ord {-# INLINE enumFrom #-} - enumFrom (C# x) = build (\ c n -> eftCharFB c n (ord# x) 255#) + enumFrom (C# x) = eftChar (ord# x) 255# -- Blarg: technically I guess enumFrom isn't strict! {-# INLINE enumFromTo #-} - enumFromTo (C# x) (C# y) = build (\ c n -> eftCharFB c n (ord# x) (ord# y)) - + enumFromTo (C# x) (C# y) = eftChar (ord# x) (ord# y) + {-# INLINE enumFromThen #-} - enumFromThen (C# x1) (C# x2) = build (\ c n -> efdCharFB c n (ord# x1) (ord# x2)) - + enumFromThen (C# x1) (C# x2) = efdChar (ord# x1) (ord# x2) + {-# INLINE enumFromThenTo #-} - enumFromThenTo (C# x1) (C# x2) (C# y) = build (\ c n -> efdtCharFB c n (ord# x1) (ord# x2) (ord# y)) + enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y) + +eftChar = eftCharList +efdChar = efdCharList +efdtChar = efdtCharList + + +{-# RULES +"eftChar" forall x y. eftChar x y = build (\c n -> eftCharFB c n x y) +"efdChar" forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2) +"efdtChar" forall x1 x2 l. efdtChar x1 x2 l = build (\ c n -> efdtCharFB c n x1 x2 l) +"eftCharList" eftCharFB (:) [] = eftCharList +"efdCharList" efdCharFB (:) [] = efdCharList +"efdtCharList" efdtCharFB (:) [] = efdtCharList + #-} + -- We can do better than for Ints because we don't -- have hassles about arithmetic overflow at maxBound @@ -263,13 +278,6 @@ go_dn_char_list x delta lim where go_dn x | x <# lim = [] | otherwise = C# (chr# x) : go_dn (x +# delta) - - -{-# RULES -"eftCharList" eftCharFB (:) [] = eftCharList -"efdCharList" efdCharFB (:) [] = efdCharList -"efdtCharList" efdtCharFB (:) [] = efdtCharList - #-} \end{code} @@ -303,17 +311,32 @@ instance Enum Int where fromEnum x = x {-# INLINE enumFrom #-} - enumFrom (I# x) = build (\ c n -> eftIntFB c n x 2147483647#) + enumFrom (I# x) = eftInt x 2147483647# -- Blarg: technically I guess enumFrom isn't strict! {-# INLINE enumFromTo #-} - enumFromTo (I# x) (I# y) = build (\ c n -> eftIntFB c n x y) + enumFromTo (I# x) (I# y) = eftInt x y {-# INLINE enumFromThen #-} - enumFromThen (I# x1) (I# x2) = build (\ c n -> efdIntFB c n x1 x2) + enumFromThen (I# x1) (I# x2) = efdInt x1 x2 {-# INLINE enumFromThenTo #-} - enumFromThenTo (I# x1) (I# x2) (I# y) = build (\ c n -> efdtIntFB c n x1 x2 y) + enumFromThenTo (I# x1) (I# x2) (I# y) = efdtInt x1 x2 y + +eftInt = eftIntList +efdInt = efdIntList +efdtInt = efdtIntList + +{-# RULES +"eftInt" forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) +"efdInt" forall x1 x2. efdInt x1 x2 = build (\ c n -> efdIntFB c n x1 x2) +"efdtInt" forall x1 x2 l. efdtInt x1 x2 l = build (\ c n -> efdtIntFB c n x1 x2 l) + +"eftIntList" eftIntFB (:) [] = eftIntList +"efdIntList" efdIntFB (:) [] = efdIntList +"efdtIntList" efdtIntFB (:) [] = efdtIntList + #-} + {-# INLINE eftIntFB #-} eftIntFB c n x y | x ># y = n @@ -384,12 +407,5 @@ go_dn_int_list x delta lim where go_dn x | x <# lim = [I# x] | otherwise = I# x : go_dn (x +# delta) - - -{-# RULES -"eftIntList" eftIntFB (:) [] = eftIntList -"efdIntList" efdIntFB (:) [] = efdIntList -"efdtIntList" efdtIntFB (:) [] = efdtIntList - #-} \end{code} diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs index 7b556eb2da..f3d435ef19 100644 --- a/ghc/lib/std/PrelException.lhs +++ b/ghc/lib/std/PrelException.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelException.lhs,v 1.13 2000/03/16 17:27:13 simonmar Exp $ +% $Id: PrelException.lhs,v 1.14 2000/03/23 17:45:31 simonpj Exp $ % % (c) The GRAP/AQUA Project, Glasgow University, 1998 % @@ -137,6 +137,8 @@ course. \begin{code} ioError :: IOError -> IO a -ioError err = throw (IOException err) +ioError err = IO $ \s -> throw (IOException err) s + -- (ioError e) isn't an exception; we only throw + -- the exception when applied to a world \end{code} diff --git a/ghc/lib/std/PrelFloat.lhs b/ghc/lib/std/PrelFloat.lhs index 889c520e7e..250da00527 100644 --- a/ghc/lib/std/PrelFloat.lhs +++ b/ghc/lib/std/PrelFloat.lhs @@ -20,7 +20,7 @@ and the classes #include "../includes/ieee-flpt.h" -module PrelFloat where +module PrelFloat( module PrelFloat, Float#, Double# ) where import {-# SOURCE #-} PrelErr import PrelBase diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index 440f4ac7d4..84e7034a0d 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -11,7 +11,6 @@ __export PrelGHC ZLzmzgZR -- (->) - All -- Pseudo class used for universal quantification CCallable CReturnable @@ -80,7 +79,6 @@ __export PrelGHC zpzh zmzh ztzh - zszh quotIntzh remIntzh gcdIntzh diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index 4222bd51ae..5372159da4 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -63,7 +63,6 @@ The @Handle@ and @Handle__@ types are defined in @IOBase@. \begin{code} {-# INLINE newHandle #-} -{-# INLINE withHandle #-} newHandle :: Handle__ -> IO Handle -- Use MVars for concurrent Haskell @@ -99,6 +98,7 @@ but we might want to revisit this in the future --SDM ]. \begin{code} withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a +{-# INLINE withHandle #-} withHandle (Handle h) act = do h_ <- takeMVar h (h',v) <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) @@ -106,6 +106,7 @@ withHandle (Handle h) act = do return v withHandle_ :: Handle -> (Handle__ -> IO a) -> IO a +{-# INLINE withHandle_ #-} withHandle_ (Handle h) act = do h_ <- takeMVar h v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) @@ -113,6 +114,7 @@ withHandle_ (Handle h) act = do return v withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO () +{-# INLINE withHandle__ #-} withHandle__ (Handle h) act = do h_ <- takeMVar h h' <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) diff --git a/ghc/lib/std/PrelList.lhs b/ghc/lib/std/PrelList.lhs index 2fecdf2221..1ea90d6d13 100644 --- a/ghc/lib/std/PrelList.lhs +++ b/ghc/lib/std/PrelList.lhs @@ -118,13 +118,13 @@ length l = len l 0# -- elements that satisfy the predicate; i.e., -- filter p xs = [ x | x <- xs, p x] filter :: (a -> Bool) -> [a] -> [a] -{-# INLINE filter #-} -filter p xs = build (\c n -> foldr (filterFB c p) n xs) +filter = filterList filterFB c p x r | p x = x `c` r | otherwise = r {-# RULES +"filter" forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs) "filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> p x && q x) "filterList" forall p. foldr (filterFB (:) p) [] = filterList p #-} @@ -186,28 +186,28 @@ scanr1 _ [] = errorEmptyList "scanr1" -- iterate f x returns an infinite list of repeated applications of f to x: -- iterate f x == [x, f x, f (f x), ...] iterate :: (a -> a) -> a -> [a] -{-# INLINE iterate #-} -iterate f x = build (\c _n -> iterateFB c f x) +iterate = iterateList iterateFB c f x = x `c` iterateFB c f (f x) iterateList f x = x : iterateList f (f x) {-# RULES -"iterate" iterateFB (:) = iterateList +"iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) +"iterateFB" iterateFB (:) = iterateList #-} -- repeat x is an infinite list, with x the value of every element. repeat :: a -> [a] -{-# INLINE repeat #-} -repeat x = build (\c _n -> repeatFB c x) +repeat = repeatList repeatFB c x = xs where xs = x `c` xs repeatList x = xs where xs = x : xs {-# RULES -"repeat" repeatFB (:) = repeatList +"repeat" forall x. repeat x = build (\c _n -> repeatFB c x) +"repeatFB" repeatFB (:) = repeatList #-} -- replicate n x is a list of length n with x the value of every element @@ -491,8 +491,7 @@ tuples are in the List library \begin{code} ---------------------------------------------- zip :: [a] -> [b] -> [(a,b)] -{-# INLINE zip #-} -zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys) +zip = zipList zipFB c x y r = (x,y) `c` r @@ -502,7 +501,8 @@ zipList (a:as) (b:bs) = (a,b) : zipList as bs zipList _ _ = [] {-# RULES -"zipList" foldr2 (zipFB (:)) [] = zipList +"zip" forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys) +"zipList" foldr2 (zipFB (:)) [] = zipList #-} \end{code} @@ -525,8 +525,8 @@ zip3 _ _ _ = [] \begin{code} ---------------------------------------------- zipWith :: (a->b->c) -> [a]->[b]->[c] -{-# INLINE zipWith #-} -zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys) +zipWith = zipWithList + zipWithFB c f x y r = (x `f` y) `c` r @@ -535,7 +535,8 @@ zipWithList f (a:as) (b:bs) = f a b : zipWithList f as bs zipWithList _ _ _ = [] {-# RULES -"zipWithList" forall f. foldr2 (zipWithFB (:) f) [] = zipWithList f +"zipWith" forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys) +"zipWithList" forall f. foldr2 (zipWithFB (:) f) [] = zipWithList f #-} \end{code} diff --git a/ghc/lib/std/PrelNum.lhs b/ghc/lib/std/PrelNum.lhs index 9af9ffaab3..1ff4c98f28 100644 --- a/ghc/lib/std/PrelNum.lhs +++ b/ghc/lib/std/PrelNum.lhs @@ -384,10 +384,21 @@ instance Enum Integer where {-# INLINE enumFromThen #-} {-# INLINE enumFromTo #-} {-# INLINE enumFromThenTo #-} - enumFrom x = build (\c _ -> enumDeltaIntegerFB c x 1) - enumFromThen x y = build (\c _ -> enumDeltaIntegerFB c x (y-x)) - enumFromTo x lim = build (\c n -> enumDeltaToIntegerFB c n x 1 lim) - enumFromThenTo x y lim = build (\c n -> enumDeltaToIntegerFB c n x (y-x) lim) + enumFrom x = efdInteger x 1 + enumFromThen x y = efdInteger x (y-x) + enumFromTo x lim = efdtInteger x 1 lim + enumFromThenTo x y lim = efdtInteger x (y-x) lim + + +efdInteger = enumDeltaIntegerList +efdtInteger = enumDeltaToIntegerList + +{-# RULES +"efdInteger" forall x y. efdInteger x y = build (\c _ -> enumDeltaIntegerFB c x y) +"efdtInteger" forall x y l.efdtInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l) +"enumDeltaInteger" enumDeltaIntegerFB (:) = enumDeltaIntegerList +"enumDeltaToInteger" enumDeltaToIntegerFB (:) [] = enumDeltaToIntegerList + #-} enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b enumDeltaIntegerFB c x d = x `c` enumDeltaIntegerFB c (x+d) d @@ -421,10 +432,6 @@ dn_list x delta lim = go (x::Integer) go x | x < lim = [] | otherwise = x : go (x+delta) -{-# RULES -"enumDeltaInteger" enumDeltaIntegerFB (:) = enumDeltaIntegerList -"enumDeltaToInteger" enumDeltaToIntegerFB (:) [] = enumDeltaToIntegerList - #-} \end{code} diff --git a/ghc/rts/HSprel.def b/ghc/rts/HSprel.def index 6aaa8fc5c5..4bacb21297 100644 --- a/ghc/rts/HSprel.def +++ b/ghc/rts/HSprel.def @@ -1,8 +1,8 @@ ; list of entry points that the RTS imports from ; the Prelude. EXPORTS -PrelBase_False_static_closure -PrelBase_True_static_closure +PrelBase_False_closure +PrelBase_True_closure PrelBase_Czh_con_info DATA PrelBase_Czh_static_info DATA PrelBase_Izh_con_info DATA @@ -21,8 +21,8 @@ PrelStable_StablePtr_con_info DATA PrelStable_StablePtr_static_info DATA PrelPack_unpackCString_closure PrelException_stackOverflow_closure -PrelException_PutFullMVar_static_closure -PrelException_BlockedOnDeadMVar_static_closure -PrelException_NonTermination_static_closure +PrelException_PutFullMVar_closure +PrelException_BlockedOnDeadMVar_closure +PrelException_NonTermination_closure __init_Prelude -__init_PrelMain
\ No newline at end of file +__init_PrelMain diff --git a/ghc/rts/Prelude.h b/ghc/rts/Prelude.h index 6489ce9fa1..5d9cc3cdc4 100644 --- a/ghc/rts/Prelude.h +++ b/ghc/rts/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Prelude.h,v 1.5 2000/03/16 17:27:13 simonmar Exp $ + * $Id: Prelude.h,v 1.6 2000/03/23 17:45:32 simonpj Exp $ * * (c) The GHC Team, 1998-2000 * @@ -15,16 +15,16 @@ */ #ifndef INTERPRETER -extern DLL_IMPORT const StgClosure PrelBase_True_static_closure; -extern DLL_IMPORT const StgClosure PrelBase_False_static_closure; +extern DLL_IMPORT const StgClosure PrelBase_True_closure; +extern DLL_IMPORT const StgClosure PrelBase_False_closure; extern DLL_IMPORT const StgClosure PrelPack_unpackCString_closure; extern DLL_IMPORT const StgClosure PrelException_stackOverflow_closure; extern DLL_IMPORT const StgClosure PrelException_heapOverflow_closure; extern const StgClosure PrelMain_mainIO_closure; -extern DLL_IMPORT const StgClosure PrelException_PutFullMVar_static_closure; -extern DLL_IMPORT const StgClosure PrelException_BlockedOnDeadMVar_static_closure; -extern DLL_IMPORT const StgClosure PrelException_NonTermination_static_closure; +extern DLL_IMPORT const StgClosure PrelException_PutFullMVar_closure; +extern DLL_IMPORT const StgClosure PrelException_BlockedOnDeadMVar_closure; +extern DLL_IMPORT const StgClosure PrelException_NonTermination_closure; extern DLL_IMPORT const StgInfoTable PrelBase_Czh_static_info; extern DLL_IMPORT const StgInfoTable PrelBase_Izh_static_info; @@ -43,13 +43,13 @@ extern DLL_IMPORT const StgInfoTable PrelAddr_W64zh_con_info; extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_static_info; extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info; -#define True_closure (&PrelBase_True_static_closure) -#define False_closure (&PrelBase_False_static_closure) +#define True_closure (&PrelBase_True_closure) +#define False_closure (&PrelBase_False_closure) #define stackOverflow_closure (&PrelException_stackOverflow_closure) #define heapOverflow_closure (&PrelException_heapOverflow_closure) -#define PutFullMVar_closure (&PrelException_PutFullMVar_static_closure) -#define BlockedOnDeadMVar_closure (&PrelException_BlockedOnDeadMVar_static_closure) -#define NonTermination_closure (&PrelException_NonTermination_static_closure) +#define PutFullMVar_closure (&PrelException_PutFullMVar_closure) +#define BlockedOnDeadMVar_closure (&PrelException_BlockedOnDeadMVar_closure) +#define NonTermination_closure (&PrelException_NonTermination_closure) #define Czh_static_info (&PrelBase_Czh_static_info) #define Izh_static_info (&PrelBase_Izh_static_info) #define Fzh_static_info (&PrelFloat_Fzh_static_info) @@ -74,14 +74,14 @@ extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info; /* We need indirections to the Prelude stuff, because we can't link * these symbols statically. */ -extern const StgClosure *ind_True_static_closure; -extern const StgClosure *ind_False_static_closure; +extern const StgClosure *ind_True_closure; +extern const StgClosure *ind_False_closure; extern const StgClosure *ind_unpackCString_closure; extern const StgClosure *ind_stackOverflow_closure; extern const StgClosure *ind_heapOverflow_closure; -extern const StgClosure *ind_PutFullMVar_static_closure; -extern const StgClosure *ind_BlockedOnDeadMVar_static_closure; -extern const StgClosure *ind_NonTermination_static_closure; +extern const StgClosure *ind_PutFullMVar_closure; +extern const StgClosure *ind_BlockedOnDeadMVar_closure; +extern const StgClosure *ind_NonTermination_closure; extern const StgInfoTable *ind_Czh_static_info; extern const StgInfoTable *ind_Izh_static_info; @@ -100,13 +100,13 @@ extern const StgInfoTable *ind_W64zh_con_info; extern const StgInfoTable *ind_StablePtr_static_info; extern const StgInfoTable *ind_StablePtr_con_info; -#define True_closure ind_True_static_closure -#define False_closure ind_False_static_closure +#define True_closure ind_True_closure +#define False_closure ind_False_closure #define stackOverflow_closure ind_stackOverflow_closure #define heapOverflow_closure ind_heapOverflow_closure -#define PutFullMVar_closure ind_PutFullMVar_static_closure -#define BlockedOnDeadMVar_closure ind_BlockedOnDeadMVar_static_closure -#define NonTermination_closure ind_NonTermination_static_closure +#define PutFullMVar_closure ind_PutFullMVar_closure +#define BlockedOnDeadMVar_closure ind_BlockedOnDeadMVar_closure +#define NonTermination_closure ind_NonTermination_closure #define Czh_static_info ind_Czh_static_info #define Izh_static_info ind_Izh_static_info #define Fzh_static_info ind_Fzh_static_info diff --git a/ghc/tests/codeGen/should_run/cg045.hs b/ghc/tests/codeGen/should_run/cg045.hs index 6bff505d21..86d239cc3b 100644 --- a/ghc/tests/codeGen/should_run/cg045.hs +++ b/ghc/tests/codeGen/should_run/cg045.hs @@ -1,3 +1,11 @@ -module Main (main) where +{-# OPTIONS -fglasgow-exts #-} + +module Main (main,myseq) where + +import PrelGHC +import PrelErr main = seq (error "hello world!" :: Int) (return ()) + +myseq :: a -> b -> b +myseq x y = case (seq# x) of { 0# -> seqError; _ -> y } diff --git a/ghc/tests/codeGen/should_run/cg047.hs b/ghc/tests/codeGen/should_run/cg047.hs new file mode 100644 index 0000000000..275bdf2d3b --- /dev/null +++ b/ghc/tests/codeGen/should_run/cg047.hs @@ -0,0 +1,18 @@ +module Main where + +-- GHC 4.04 +-- I've been having problems getting GHC to compile some code I'm working +-- on with optimisation (-O) turned on. Compilation is fine without -O +-- specified. Through a process of elimination I've managed to reproduce +-- the problemin the following (much simpler) piece of code: + +import List + +test es = + concat (groupBy eq (zip [0..(length es) - 1] es)) + where + eq a b = (fst a) == (fst b) + +main = putStr (show (test [1,2,3,4])) + + diff --git a/ghc/tests/codeGen/should_run/cg047.stdout b/ghc/tests/codeGen/should_run/cg047.stdout new file mode 100644 index 0000000000..732d4fe8ff --- /dev/null +++ b/ghc/tests/codeGen/should_run/cg047.stdout @@ -0,0 +1 @@ +[(0,1),(1,2),(2,3),(3,4)]
\ No newline at end of file diff --git a/ghc/tests/io/should_run/io013.hs b/ghc/tests/io/should_run/io013.hs index ba93a25780..a59921eba1 100644 --- a/ghc/tests/io/should_run/io013.hs +++ b/ghc/tests/io/should_run/io013.hs @@ -1,3 +1,7 @@ +-- If you're testing on a Win32 box, be aware that +-- line termination conventions differ (and that +-- io013 uses /dev/null, which is also unix centric.) + import IO -- 1.3 main = do diff --git a/ghc/tests/reader/should_fail/read001.stderr b/ghc/tests/reader/should_fail/read001.stderr index 6e32bbe064..9fd0f2b2bc 100644 --- a/ghc/tests/reader/should_fail/read001.stderr +++ b/ghc/tests/reader/should_fail/read001.stderr @@ -30,16 +30,27 @@ f _ ((n+42)) = y expr a b c d - = ((((...) + (...)) - + (case ... of + = ((((((((a + (: a b)) + (a : b)) + (((1 - 'c') - "abc") - 1.293)) + + ((\ x y z -> x) 42)) + + ((9 *))) + + ((* 8))) + + (case x of Prelude.[] - | ... -> ... - | ... -> ... - | ... -> ... + | null x -> 99 + | otherwise -> 98 + | True -> 97 where - ...)) + null x = False)) + ([z | z <- c, isSpace z])) - + (let y = ... in ((...) + (...)) + ([..., ... .. ...])) + + (let y = foo + in + (((((((y + [1, 2, 3, 4]) + (4, 3, 2, 1)) + + (4 :: {- implicit forall -} (Num a) => a)) + + (if 42 == 42.0 then 1 else 4)) + + ([1 .. ])) + + ([2, 4 .. ])) + + ([3 .. 5])) + + ([4, 8 .. 999])) mat a b c d | foof a b = d | foof a c = d diff --git a/ghc/tests/rename/should_compile/rn033.hs b/ghc/tests/rename/should_compile/rn033.hs index c6cd70cf1f..62aba9183e 100644 --- a/ghc/tests/rename/should_compile/rn033.hs +++ b/ghc/tests/rename/should_compile/rn033.hs @@ -1,8 +1,14 @@ --- !!! Checking that lazy name clashing work. +-- !!! Checking that lazy name clashing works module ShouldSucceed where import List ( sort ) -ShouldSucceed.sort :: Int -ShouldSucceed.sort = 3 +sort :: Int +sort = 3 + +foo :: Int +foo = ShouldSucceed.sort + +baz :: (Ord a) => [a] -> [a] +baz = List.sort diff --git a/ghc/tests/typecheck/should_compile/tc038.stderr b/ghc/tests/typecheck/should_compile/tc038.stderr index 86f60e73f1..989868b9c1 100644 --- a/ghc/tests/typecheck/should_compile/tc038.stderr +++ b/ghc/tests/typecheck/should_compile/tc038.stderr @@ -1,2 +1,2 @@ __export ShouldSucceed f; -1 f :: __forall [a] => {PrelNum.Num a} -> {PrelBase.Eq a} -> [a] -> [a] ; +1 f :: __forall [a] => {PrelNum.Num a} -> [a] -> [a] ; diff --git a/ghc/tests/typecheck/should_compile/tc049.stderr b/ghc/tests/typecheck/should_compile/tc049.stderr index a8c1e88045..6a1df40599 100644 --- a/ghc/tests/typecheck/should_compile/tc049.stderr +++ b/ghc/tests/typecheck/should_compile/tc049.stderr @@ -1,5 +1,5 @@ __export ShouldSucceed fib main1 main2 main3 mem mem1 mem2 mem3 mem4 oR oR1; -1 fib :: __forall [a] => {PrelNum.Num a} -> {PrelBase.Ord a} -> a -> a ; +1 fib :: __forall [a] => {PrelBase.Ord a} -> {PrelNum.Num a} -> a -> a ; 1 main1 :: PrelBase.Bool ; 1 main2 :: PrelBase.Bool ; 1 main3 :: PrelBase.Bool ; diff --git a/ghc/tests/typecheck/should_compile/tc050.stderr b/ghc/tests/typecheck/should_compile/tc050.stderr index 3dd67fb3d2..b9ea2fb252 100644 --- a/ghc/tests/typecheck/should_compile/tc050.stderr +++ b/ghc/tests/typecheck/should_compile/tc050.stderr @@ -3,7 +3,7 @@ instance {Foo PrelBase.Bool} = zdfFooBool; instance {Foo PrelBase.Int} = zdfFooInt; 1 class Foo a where {o_and :: a -> a -> a} ; 1 f :: __forall [t] => PrelBase.Bool -> t -> PrelBase.Bool ; -1 g :: __forall [t a] => {PrelNum.Num a} -> {Foo a} -> a -> t -> a ; +1 g :: __forall [t a] => {Foo a} -> {PrelNum.Num a} -> a -> t -> a ; 1 zddmo_and :: __forall [a] => {Foo a} -> a -> a -> a ; 1 zdfFooBool :: {Foo PrelBase.Bool} ; 1 zdfFooInt :: {Foo PrelBase.Int} ; diff --git a/ghc/tests/typecheck/should_compile/tc053.stderr b/ghc/tests/typecheck/should_compile/tc053.stderr index 3b5db93f00..21caf583ef 100644 --- a/ghc/tests/typecheck/should_compile/tc053.stderr +++ b/ghc/tests/typecheck/should_compile/tc053.stderr @@ -2,7 +2,7 @@ __export ShouldSucceed Eqzq{deq} f; instance {Eqzq PrelBase.Int} = zdfEqzqInt; instance __forall [a] => {Eqzq a} -> {Eqzq [a]} = zdfEqzqZMZN; 1 class Eqzq a where {deq :: a -> a -> PrelBase.Bool} ; -1 f :: __forall [t] => {PrelNum.Num t} -> {Eqzq [t]} -> [t] -> PrelBase.Bool ; +1 f :: __forall [t] => {Eqzq [t]} -> {PrelNum.Num t} -> [t] -> PrelBase.Bool ; 1 zddmdeq :: __forall [a] => {Eqzq a} -> a -> a -> PrelBase.Bool ; 1 zdfEqzqInt :: {Eqzq PrelBase.Int} ; 1 zdfEqzqZMZN :: __forall [a] => {Eqzq a} -> {Eqzq [a]} ; diff --git a/ghc/tests/typecheck/should_compile/tc054.stderr b/ghc/tests/typecheck/should_compile/tc054.stderr index 794639d3a1..7e6417b022 100644 --- a/ghc/tests/typecheck/should_compile/tc054.stderr +++ b/ghc/tests/typecheck/should_compile/tc054.stderr @@ -3,7 +3,7 @@ instance {Eqzq PrelBase.Int} = zdfEqzqInt; instance {Ordzq PrelBase.Int} = zdfOrdzqInt; 1 class Eqzq a where {doubleeq :: a -> a -> PrelBase.Bool} ; 1 class {Eqzq a} => Ordzq a where {lt :: a -> a -> PrelBase.Bool} ; -1 f :: __forall [t a] => {PrelNum.Num a} -> {Ordzq a} -> a -> t -> PrelBase.Bool ; +1 f :: __forall [t a] => {Ordzq a} -> {PrelNum.Num a} -> a -> t -> PrelBase.Bool ; 1 zddmdoubleeq :: __forall [a] => {Eqzq a} -> a -> a -> PrelBase.Bool ; 1 zddmlt :: __forall [a] => {Ordzq a} -> a -> a -> PrelBase.Bool ; 1 zdfEqzqInt :: {Eqzq PrelBase.Int} ; diff --git a/ghc/tests/typecheck/should_compile/tc056.stderr b/ghc/tests/typecheck/should_compile/tc056.stderr index c32b4e2113..f252e5ec66 100644 --- a/ghc/tests/typecheck/should_compile/tc056.stderr +++ b/ghc/tests/typecheck/should_compile/tc056.stderr @@ -7,7 +7,7 @@ instance {Eqzq PrelBase.Int} = zdfEqzqInt; instance __forall [a] => {Eqzq a} -> {Eqzq a} -> {Eqzq [a]} = zdfEqzqZMZN; 1 class Eqzq a where {doubleeq :: a -> a -> PrelBase.Bool} ; 1 class {Eqzq a} => Ordzq a where {lt :: a -> a -> PrelBase.Bool} ; -1 f :: __forall [t t1] => {PrelNum.Num t1} -> {Eqzq [t1]} -> [t1] -> t -> PrelBase.Bool ; +1 f :: __forall [t t1] => {Eqzq [t1]} -> {PrelNum.Num t1} -> [t1] -> t -> PrelBase.Bool ; 1 zddmdoubleeq :: __forall [a] => {Eqzq a} -> a -> a -> PrelBase.Bool ; 1 zddmlt :: __forall [a] => {Ordzq a} -> a -> a -> PrelBase.Bool ; 1 zdfEqzqInt :: {Eqzq PrelBase.Int} ; diff --git a/ghc/tests/typecheck/should_compile/tc058.stderr b/ghc/tests/typecheck/should_compile/tc058.stderr index e5e069cb65..184d13c54b 100644 --- a/ghc/tests/typecheck/should_compile/tc058.stderr +++ b/ghc/tests/typecheck/should_compile/tc058.stderr @@ -4,7 +4,7 @@ instance __forall [a] => {Eq2 a} -> {Ord2 a} -> {Eq2 [a]} = zdfEq2ZMZN; instance {Ord2 PrelBase.Int} = zdfOrd2Int; 1 class Eq2 a where {doubleeq :: a -> a -> PrelBase.Bool} ; 1 class {Eq2 a} => Ord2 a where {lt :: a -> a -> PrelBase.Bool} ; -1 f :: __forall [t t1] => {PrelNum.Num t1} -> {Eq2 [t1]} -> [t1] -> t -> PrelBase.Bool ; +1 f :: __forall [t t1] => {Eq2 [t1]} -> {PrelNum.Num t1} -> [t1] -> t -> PrelBase.Bool ; 1 zddmdoubleeq :: __forall [a] => {Eq2 a} -> a -> a -> PrelBase.Bool ; 1 zddmlt :: __forall [a] => {Ord2 a} -> a -> a -> PrelBase.Bool ; 1 zdfEq2Int :: {Eq2 PrelBase.Int} ; diff --git a/ghc/tests/typecheck/should_compile/tc059.stderr b/ghc/tests/typecheck/should_compile/tc059.stderr index e0b951cc9b..4adcd1a8b2 100644 --- a/ghc/tests/typecheck/should_compile/tc059.stderr +++ b/ghc/tests/typecheck/should_compile/tc059.stderr @@ -2,7 +2,7 @@ __export ShouldSucceed Eq2{deq foo} f; instance {Eq2 PrelBase.Int} = zdfEq2Int; instance __forall [a] => {Eq2 a} -> {Eq2 [a]} = zdfEq2ZMZN; 1 class Eq2 a where {deq :: a -> a -> PrelBase.Bool; foo :: a -> a} ; -1 f :: __forall [t] => {PrelNum.Num t} -> {Eq2 [t]} -> [t] -> PrelBase.Bool ; +1 f :: __forall [t] => {Eq2 [t]} -> {PrelNum.Num t} -> [t] -> PrelBase.Bool ; 1 zddmdeq :: __forall [a] => {Eq2 a} -> a -> a -> PrelBase.Bool ; 1 zddmfoo :: __forall [a] => {Eq2 a} -> a -> a ; 1 zdfEq2Int :: {Eq2 PrelBase.Int} ; diff --git a/ghc/tests/typecheck/should_compile/tc087.stderr b/ghc/tests/typecheck/should_compile/tc087.stderr index b29063d2d5..91bd7a892f 100644 --- a/ghc/tests/typecheck/should_compile/tc087.stderr +++ b/ghc/tests/typecheck/should_compile/tc087.stderr @@ -2,10 +2,10 @@ __export ShouldSucceed PriorityQueue{empty single insert meld splitMin} SeqView{ 1 check :: __forall [q :: (* -> *)] => {PriorityQueue q} -> (__forall [a] => {PrelBase.Ord a} -> q a) -> PrelIOBase.IO PrelBase.Z0T ; 1 class PriorityQueue q :: (* -> *) where {empty :: __forall [a] => {PrelBase.Ord a} -> q a; single :: __forall [a] => {PrelBase.Ord a} -> a -> q a; insert = :: __forall [a] => {PrelBase.Ord a} -> a -> q a -> q a; meld :: __forall [a] => {PrelBase.Ord a} -> q a -> q a -> q a; splitMin :: __forall [a] => {PrelBase.Ord a} -> q a -> SeqView q a} ; 1 data SeqView t :: (* -> *) a = Null | Cons a (t a) ; -1 insertMany :: __forall [q :: (* -> *) a] => {PrelBase.Ord a} -> {PriorityQueue q} -> [a] -> q a -> q a ; +1 insertMany :: __forall [q :: (* -> *) a] => {PriorityQueue q} -> {PrelBase.Ord a} -> [a] -> q a -> q a ; 1 out :: __forall [a] => {PrelNum.Num a} -> [a] -> PrelIOBase.IO PrelBase.Z0T ; -1 pqSort :: __forall [a t :: (* -> *)] => {PriorityQueue t} -> {PrelBase.Ord a} -> t a -> [a] -> [a] ; -1 toOrderedList :: __forall [t :: (* -> *) a] => {PrelBase.Ord a} -> {PriorityQueue t} -> t a -> [a] ; +1 pqSort :: __forall [a t :: (* -> *)] => {PrelBase.Ord a} -> {PriorityQueue t} -> t a -> [a] -> [a] ; +1 toOrderedList :: __forall [t :: (* -> *) a] => {PriorityQueue t} -> {PrelBase.Ord a} -> t a -> [a] ; 1 zddmempty :: __forall [q :: (* -> *)] => {PriorityQueue q} -> (__forall [a] => {PrelBase.Ord a} -> q a) ; 1 zddminsert :: __forall [q :: (* -> *)] => {PriorityQueue q} -> (__forall [a] => {PrelBase.Ord a} -> a -> q a -> q a) ; 1 zddmmeld :: __forall [q :: (* -> *)] => {PriorityQueue q} -> (__forall [a] => {PrelBase.Ord a} -> q a -> q a -> q a) ; diff --git a/ghc/tests/typecheck/should_compile/tc095.stderr b/ghc/tests/typecheck/should_compile/tc095.stderr index 0c185cd69c..5e32ebad17 100644 --- a/ghc/tests/typecheck/should_compile/tc095.stderr +++ b/ghc/tests/typecheck/should_compile/tc095.stderr @@ -1,11 +1,11 @@ NOTE: Simplifier still going after 4 iterations; bailing out. __export ShouldSucceed HappyAbsSyn{HappyTerminal HappyErrorToken HappyAbsSyn1 HappyAbsSyn2 HappyAbsSyn3} HappyState{HappyState} Token{TokenInt TokenVar TokenEq} action_0 action_1 action_2 action_3 action_4 action_5 action_6 happyAccept happyError happyFail happyGoto happyMonadReduce happyNewToken happyParse happyReduce happyReduce_1 happyReduce_2 happyReduce_3 happyReturn happyShift happySpecReduce_0 happySpecReduce_1 happySpecReduce_2 happySpecReduce_3 happyThen main myparser notHappyAtAll; instance {PrelShow.Show Token} = zdfShowToken; -1 action_0 :: __forall [t t1] => {PrelNum.Num t} -> t -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn (t1 -> PrelFloat.Double) [([PrelBase.Char], t1 -> PrelBase.Int)] (t1 -> PrelBase.Int)] -> [Token] -> t1 -> PrelFloat.Double) -> [HappyState Token ([HappyAbsSyn (t1 -> PrelFloat.Double) [([PrelBase.Char], t1 -> PrelBase.Int)] (t1 -> PrelBase.Int)] -> [Token] -> t1 -> PrelFloat.Double)] -> [HappyAbsSyn (t1 -> PrelFloat.Double) [([PrelBase.Char], t1 -> PrelBase.Int)] (t1 -> PrelBase.Int)] -> [Token] -> t1 -> PrelFloat.Double ; -1 action_1 :: __forall [t t1 t2 t3 b] => {PrelNum.Num t} -> t -> PrelBase.Int -> b -> HappyState b ([HappyAbsSyn t1 t2 t3] -> [Token] -> t1) -> [HappyState b ([HappyAbsSyn t1 t2 t3] -> [Token] -> t1)] -> [HappyAbsSyn t1 t2 t3] -> [Token] -> t1 ; +1 action_0 :: __forall [t t1] => {PrelNum.Num t} -> {PrelBase.Eq t} -> t -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn (t1 -> PrelFloat.Double) [([PrelBase.Char], t1 -> PrelBase.Int)] (t1 -> PrelBase.Int)] -> [Token] -> t1 -> PrelFloat.Double) -> [HappyState Token ([HappyAbsSyn (t1 -> PrelFloat.Double) [([PrelBase.Char], t1 -> PrelBase.Int)] (t1 -> PrelBase.Int)] -> [Token] -> t1 -> PrelFloat.Double)] -> [HappyAbsSyn (t1 -> PrelFloat.Double) [([PrelBase.Char], t1 -> PrelBase.Int)] (t1 -> PrelBase.Int)] -> [Token] -> t1 -> PrelFloat.Double ; +1 action_1 :: __forall [t t1 t2 t3 b] => {PrelNum.Num t} -> {PrelBase.Eq t} -> t -> PrelBase.Int -> b -> HappyState b ([HappyAbsSyn t1 t2 t3] -> [Token] -> t1) -> [HappyState b ([HappyAbsSyn t1 t2 t3] -> [Token] -> t1)] -> [HappyAbsSyn t1 t2 t3] -> [Token] -> t1 ; 1 action_2 :: __forall [t t1 b t2 t3 t4 t5 t31] => t -> PrelBase.Int -> b -> t2 -> [HappyState b ([HappyAbsSyn (t3 -> PrelFloat.Double) [(t4, t3 -> t5)] t31] -> t1)] -> [HappyAbsSyn (t3 -> PrelFloat.Double) [(t4, t3 -> t5)] t31] -> t1 ; -1 action_3 :: __forall [t t1 t11 a] => {PrelNum.Num t} -> t -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a) -> [HappyState Token ([HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a)] -> [HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a ; -1 action_4 :: __forall [t t1 t11 a] => {PrelNum.Num t} -> t -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a) -> [HappyState Token ([HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a)] -> [HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a ; +1 action_3 :: __forall [t t1 t11 a] => {PrelNum.Num t} -> {PrelBase.Eq t} -> t -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a) -> [HappyState Token ([HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a)] -> [HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a ; +1 action_4 :: __forall [t t1 t11 a] => {PrelNum.Num t} -> {PrelBase.Eq t} -> t -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a) -> [HappyState Token ([HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a)] -> [HappyAbsSyn t1 [([PrelBase.Char], t11 -> PrelBase.Int)] (t11 -> PrelBase.Int)] -> [Token] -> a ; 1 action_5 :: __forall [t t1 b t2 t11 t3] => t -> PrelBase.Int -> b -> t2 -> [HappyState b ([HappyAbsSyn t11 [([PrelBase.Char], t3)] t3] -> t1)] -> [HappyAbsSyn t11 [([PrelBase.Char], t3)] t3] -> t1 ; 1 action_6 :: __forall [t t1 b t2 t11 t21 t3] => t -> PrelBase.Int -> b -> t2 -> [HappyState b ([HappyAbsSyn t11 t21 (t3 -> PrelBase.Int)] -> t1)] -> [HappyAbsSyn t11 t21 (t3 -> PrelBase.Int)] -> t1 ; 1 data HappyAbsSyn t1 t2 t3 = HappyTerminal Token | HappyErrorToken PrelBase.Int | HappyAbsSyn1 t1 | HappyAbsSyn2 t2 | HappyAbsSyn3 t3 ; @@ -23,7 +23,7 @@ instance {PrelShow.Show Token} = zdfShowToken; 1 happyReduce_2 :: __forall [t b t1 t11 t3] => PrelBase.Int -> b -> t1 -> [HappyState b ([HappyAbsSyn t11 [([PrelBase.Char], t3)] t3] -> t)] -> [HappyAbsSyn t11 [([PrelBase.Char], t3)] t3] -> t ; 1 happyReduce_3 :: __forall [t b t1 t11 t2 t21] => PrelBase.Int -> b -> t1 -> [HappyState b ([HappyAbsSyn t11 t2 (t21 -> PrelBase.Int)] -> t)] -> [HappyAbsSyn t11 t2 (t21 -> PrelBase.Int)] -> t ; 1 happyReturn :: __forall [t t1] => t -> t1 -> t ; -1 happyShift :: __forall [t t1 t2 t3 t11] => {PrelNum.Num t} -> (PrelBase.Int -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn t1 t2 t3] -> [Token] -> t11) -> [HappyState Token ([HappyAbsSyn t1 t2 t3] -> [Token] -> t11)] -> [HappyAbsSyn t1 t2 t3] -> [Token] -> t11) -> t -> Token -> HappyState Token ([HappyAbsSyn t1 t2 t3] -> [Token] -> t11) -> [HappyState Token ([HappyAbsSyn t1 t2 t3] -> [Token] -> t11)] -> [HappyAbsSyn t1 t2 t3] -> [Token] -> t11 ; +1 happyShift :: __forall [t t1 t2 t3 t11] => {PrelNum.Num t} -> {PrelBase.Eq t} -> (PrelBase.Int -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn t1 t2 t3] -> [Token] -> t11) -> [HappyState Token ([HappyAbsSyn t1 t2 t3] -> [Token] -> t11)] -> [HappyAbsSyn t1 t2 t3] -> [Token] -> t11) -> t -> Token -> HappyState Token ([HappyAbsSyn t1 t2 t3] -> [Token] -> t11) -> [HappyState Token ([HappyAbsSyn t1 t2 t3] -> [Token] -> t11)] -> [HappyAbsSyn t1 t2 t3] -> [Token] -> t11 ; 1 happySpecReduce_0 :: __forall [t a b] => PrelBase.Int -> t -> PrelBase.Int -> b -> HappyState b ([t] -> [Token] -> a) -> [HappyState b ([t] -> [Token] -> a)] -> [t] -> [Token] -> a ; 1 happySpecReduce_1 :: __forall [t b t1 t2] => PrelBase.Int -> (t1 -> t1) -> PrelBase.Int -> b -> t -> [HappyState b ([t1] -> t2)] -> [t1] -> t2 ; 1 happySpecReduce_2 :: __forall [t b t1 t2] => PrelBase.Int -> (t1 -> t1 -> t1) -> PrelBase.Int -> b -> t -> [HappyState b ([t1] -> t2)] -> [t1] -> t2 ; diff --git a/ghc/tests/typecheck/should_fail/tcfail007.stderr b/ghc/tests/typecheck/should_fail/tcfail007.stderr index e29d70ee6b..ad50c0f52a 100644 --- a/ghc/tests/typecheck/should_fail/tcfail007.stderr +++ b/ghc/tests/typecheck/should_fail/tcfail007.stderr @@ -1,7 +1,8 @@ tcfail007.hs:3: No instance for `Num Bool' - arising from use of `+' at tcfail007.hs:3 + arising from the literal `1' at tcfail007.hs:3 + In the second argument of `+', namely `1' In the right-hand side of an equation for `n': x + 1 Compilation had errors diff --git a/ghc/tests/typecheck/should_fail/tcfail010.stderr b/ghc/tests/typecheck/should_fail/tcfail010.stderr index 4543690acc..3712503dcc 100644 --- a/ghc/tests/typecheck/should_fail/tcfail010.stderr +++ b/ghc/tests/typecheck/should_fail/tcfail010.stderr @@ -1,7 +1,8 @@ tcfail010.hs:3: Ambiguous type variable(s) `t' in the constraint `Num [t]' - arising from use of `+' at tcfail010.hs:3 + arising from the literal `2' at tcfail010.hs:3 + In the second argument of `+', namely `2' In the right-hand side of a lambda abstraction: z + 2 Compilation had errors diff --git a/ghc/tests/typecheck/should_fail/tcfail036.stderr b/ghc/tests/typecheck/should_fail/tcfail036.stderr index 9d0679bd67..ba8ddf2eb8 100644 --- a/ghc/tests/typecheck/should_fail/tcfail036.stderr +++ b/ghc/tests/typecheck/should_fail/tcfail036.stderr @@ -5,11 +5,11 @@ tcfail036.hs:3: defined at tcfail036.hs:8 and defined at tcfail036.hs:6 tcfail036.hs:8: - No instance for `Show NUM' + No instance for `Eq NUM' arising from an instance declaration at tcfail036.hs:8 tcfail036.hs:8: - No instance for `Eq NUM' + No instance for `Show NUM' arising from an instance declaration at tcfail036.hs:8 tcfail036.hs:9: diff --git a/ghc/tests/typecheck/should_fail/tcfail043.stderr b/ghc/tests/typecheck/should_fail/tcfail043.stderr index 0a4804fd3c..52e29146fe 100644 --- a/ghc/tests/typecheck/should_fail/tcfail043.stderr +++ b/ghc/tests/typecheck/should_fail/tcfail043.stderr @@ -9,5 +9,15 @@ tcfail043.hs:38: else if eq a (hd bs) then True else search a (tl bs) +tcfail043.hs:40: + Ambiguous type variable(s) `a' in the constraint `Eq_ a' + arising from use of `eq' at tcfail043.hs:40 + In the predicate expression: eq a (hd bs) + In the right-hand side of a lambda abstraction: + if gt (hd bs) a then + False + else + if eq a (hd bs) then True else search a (tl bs) + Compilation had errors diff --git a/ghc/tests/typecheck/should_fail/tcfail080.stderr b/ghc/tests/typecheck/should_fail/tcfail080.stderr index ebed17d42f..0e40dd8dc4 100644 --- a/ghc/tests/typecheck/should_fail/tcfail080.stderr +++ b/ghc/tests/typecheck/should_fail/tcfail080.stderr @@ -1,7 +1,8 @@ tcfail080.hs:11: Ambiguous type variable(s) `c' in the constraint `Collection c a' - arising from use of `isempty' at tcfail080.hs:11 + arising from use of `singleton' at tcfail080.hs:11 + In the first argument of `isempty', namely `(singleton x)' In the right-hand side of an equation for `q': isempty (singleton x) |