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
# -----------------------------------------------------------------------------
-# $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
DIRS += nativeGen
else
SRC_HC_OPTS += -DOMIT_NATIVE_CODEGEN
+ifeq ($(GhcWithIlx),YES)
+DIRS += ilxGen
+SRC_HC_OPTS += -DILX
+endif
endif
%
% (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}
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 )
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) ***
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`
= 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) ->
%
% (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}
mkStaticConEntryLabel,
mkRednCountsLabel,
mkConInfoTableLabel,
- mkStaticClosureLabel,
mkStaticInfoTableLabel,
mkApEntryLabel,
mkApInfoTableLabel,
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)
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
case info of
ConInfoTbl -> InfoTblType
StaticInfoTbl -> InfoTblType
- StaticClosure -> ClosureType
_ -> CodeType
labelType _ = DataType
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
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")
\begin{code}
module CStrings(
+ CLabelString, isCLabelString,
cSEP, pp_cSEP,
stringToC, charToC, pprFSInCStyle,
#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)
| 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
'\'' -> "\\'"
_ -> [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')
%
% (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
% ---------------------------------------------------------------------------
-- 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
-}
-- ---------------------------------------------------------------------------
\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}
)
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
)
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-} )
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
-- 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
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
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
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("};")
(($$) ((<>) (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}
= 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
-- 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
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*
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
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}
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]
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
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}
\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"
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}
+
+++ /dev/null
-_interface_ Const 1
-_exports_
-Const Con ;
-_declarations_
-1 data Con ;
+++ /dev/null
-__interface Const 1 0 where
-__export Const Con ;
-1 data Con ;
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
-
-\begin{code}
-module Const (
- Con(..),
- conType, conPrimRep,
- conOkForApp, conOkForAlt, isWHNFCon, isDataCon, 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}
-
_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 ;;
__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 ;
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
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 )
import Outputable
import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields )
+import PprType () -- Instances
import UniqSet
import Maybes ( maybeToBool )
import Maybe
\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}
--
-- 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)
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
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
-> [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
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
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 &&
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
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)
-> [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
isExistentialDataCon :: DataCon -> Bool
isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
+
+isDynDataCon :: DataCon -> Bool
+isDynDataCon con = isDynName (dataConName con)
\end{code}
-- Returns (Just ...) for any
-- single-constructor
- -- non-recursive type
-- not existentially quantified
-- type whether a data type or a new type
--
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
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)
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"
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}
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).
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,
-- IdInfo stuff
setIdUnfolding,
- setIdArity,
+ setIdArityInfo,
setIdDemandInfo,
setIdStrictness,
setIdWorkerInfo,
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
import {-# SOURCE #-} CoreUnfold ( Unfolding )
import {-# SOURCE #-} CoreSyn ( CoreRules )
+import BasicTypes ( Arity )
import Var ( Id, DictId,
isId, mkIdVar,
idName, idType, idUnique, idInfo,
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 )
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}
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.
| 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
-- 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}
\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
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
---------------------------------
-- 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
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
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,
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 )
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
zapSpecPragInfo info = case flavourInfo info of
SpecPragmaId -> info { flavourInfo = VanillaId }
other -> info
-
\end{code}
arityInfo = UnknownArity,
demandInfo = wwLazy,
specInfo = emptyCoreRules,
- workerInfo = Nothing,
+ workerInfo = NoWorker,
strictnessInfo = NoStrictnessInfo,
unfoldingInfo = noUnfolding,
updateInfo = NoUpdateInfo,
\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` ()
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.
atLeastArity = ArityAtLeast
unknownArity = UnknownArity
-arityLowerBound :: ArityInfo -> Int
+arityLowerBound :: ArityInfo -> Arity
arityLowerBound UnknownArity = 0
arityLowerBound (ArityAtLeast n) = n
arityLowerBound (ArityExactly n) = n
%************************************************************************
%* *
-\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@}
%* *
%************************************************************************
\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}
\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
_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 ;;
__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 ;
mkDictFunId, mkDefaultMethodId,
mkDictSelId,
- mkDataConId,
+ mkDataConId, mkDataConWrapId,
mkRecordSelId,
- mkNewTySelId,
- mkPrimitiveId,
+ mkPrimOpId, mkCCallOpId,
-- And some particular Ids; see below for why they are wired in
wiredInIds,
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
%************************************************************************
\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
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
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}
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
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}
%************************************************************************
%* *
-\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
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
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}
%************************************************************************
\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}
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
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}
-- The Name type
Name, -- Abstract
- mkLocalName, mkImportedLocalName, mkSysLocalName,
+ mkLocalName, mkImportedLocalName, mkSysLocalName, mkCCallName,
mkTopName, mkIPName,
mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
mkWiredInIdName, mkWiredInTyConName,
tidyTopName,
nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule,
- isUserExportedName, isUserImportedExplicitlyName, nameSrcLoc,
- isLocallyDefinedName,
+ isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, nameSrcLoc,
+ isLocallyDefinedName, isDynName,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
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 )
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
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
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,
\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
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!
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
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 )
\begin{code}
data PprEnv bndr
= PE {
- pCon :: Con -> SDoc,
pSCC :: CostCentre -> SDoc,
pTyVarO :: TyVar -> SDoc, -- to print tyvar occurrences
\begin{code}
initPprEnv
- :: Maybe (Con -> SDoc)
- -> Maybe (CostCentre -> SDoc)
+ :: Maybe (CostCentre -> SDoc)
-> Maybe (TyVar -> SDoc)
-> Maybe (Type -> SDoc)
-> Maybe (BindingSite -> bndr -> SDoc)
-- 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)
mkRdrUnqual, mkRdrQual,
mkSrcUnqual, mkSrcQual,
mkSysUnqual, mkSysQual,
- mkPreludeQual, qualifyRdrName,
+ mkPreludeQual, qualifyRdrName, mkRdrNameWkr,
dummyRdrVarName, dummyRdrTcName,
-- Destruction
OccName,
mkSysOccFS,
mkSrcOccFS, mkSrcVarOcc,
- isDataOcc, isTvOcc
+ isDataOcc, isTvOcc, mkWorkerOcc
)
import Module ( ModuleName, pprModuleName,
mkSysModuleFS, mkSrcModuleFS
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}
initTyVarUnique,
initTidyUniques,
+ isTupleKey,
+
-- now all the built-in Uniques (and functions to make them)
-- [the Oh-So-Wonderful Haskell module system wins again...]
mkAlphaTyVarUnique,
incrUnique :: Unique -> Unique
deriveUnique :: Unique -> Int -> Unique
+
+isTupleKey :: Unique -> Bool
\end{code}
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
%************************************************************************
\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}
%************************************************************************
\begin{code}
module Var (
- Var, IdOrTyVar, VarDetails, -- Abstract
+ Var, VarDetails, -- Abstract
varName, varUnique, varInfo, varType,
setVarName, setVarUnique, setVarType, setVarOcc,
in its @VarDetails@.
\begin{code}
-type IdOrTyVar = Var
-
data Var
= Var {
varName :: Name,
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}
(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}
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}
\begin{code}
module VarSet (
- VarSet, IdSet, TyVarSet, IdOrTyVarSet, UVarSet,
+ VarSet, IdSet, TyVarSet, UVarSet,
emptyVarSet, unitVarSet, mkVarSet,
extendVarSet,
elemVarSet, varSetElems, subVarSet,
#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 )
type VarSet = UniqSet Var
type IdSet = UniqSet Id
type TyVarSet = UniqSet TyVar
-type IdOrTyVarSet = UniqSet IdOrTyVar
type UVarSet = UniqSet UVar
emptyVarSet :: VarSet
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 )
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
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 )
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}
%************************************************************************
%
% (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 $
%
%********************************************************
%* *
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(..)
)
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 ->
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)
=
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
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(..) )
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 ->
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}
%************************************************************************
-- 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
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}
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`
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}
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
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
-- 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...)
-- 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}
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 )
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.
= 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
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}
mkConCodeAndInfo con
= let
- arg_tys = dataConAllRawArgTys con
+ arg_tys = dataConRepArgTys con
(closure_info, arg_things)
= layOutDynCon con typePrimRep arg_tys
%
% (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 $
%
%********************************************************
%* *
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 )
%********************************************************
\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
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}
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
(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
-- 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
(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.
temp_amodes = zipWith CTemp temp_uniqs prim_reps
in
returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
-
\end{code}
%
% (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}
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 )
%
% (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 $
%
%********************************************************
%* *
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(..) )
%
% (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}
import CgRetConv ( assignRegs )
import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
mkInfoTableLabel,
- mkConInfoTableLabel, mkStaticClosureLabel,
+ mkConInfoTableLabel,
mkCAFBlackHoleInfoTableLabel,
mkSECAFBlackHoleInfoTableLabel,
mkStaticInfoTableLabel, mkStaticConEntryLabel,
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
)
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
-- 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
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}
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}
\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}
%************************************************************************
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}
%************************************************************************
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
-- 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
-- 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
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
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
-- 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
\begin{code}
module SMRep (
SMRep(..), ClosureType(..),
- isConstantRep, isStaticRep,
+ isStaticRep,
fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize,
fixedItblSize, pprSMRep
\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.
\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"
#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 )
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
-- 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
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
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)
\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
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
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
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
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
#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
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 )
-- 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 ()
\begin{code}
lintUnfolding :: SrcLoc
- -> [IdOrTyVar] -- Treat these as in scope
+ -> [Var] -- Treat these as in scope
-> CoreExpr
-> Maybe Message -- Nothing => OK
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 ->
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) $
= 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`
-- 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`
%************************************************************************
\begin{code}
-lintBinder :: IdOrTyVar -> LintM ()
+lintBinder :: Var -> LintM ()
lintBinder v = nopL
-- ToDo: lint its type
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)
------------------------------------------------------
-- 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)
------------------------------------------------------
-- 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),
_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 ;;
__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 ;
\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,
coreBindsSize,
-- Annotated expressions
- AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate,
+ AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, deAnnotate',
-- Core rules
CoreRules(..), -- Representation needed by friends
#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
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)
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))]
\begin{code}
data CoreRules
= Rules [CoreRule]
- IdOrTyVarSet -- Locally-defined free vars of RHSs
+ VarSet -- Locally-defined free vars of RHSs
type RuleName = FAST_STRING
isEmptyCoreRules :: CoreRules -> Bool
isEmptyCoreRules (Rules rs _) = null rs
-rulesRhsFreeVars :: CoreRules -> IdOrTyVarSet
+rulesRhsFreeVars :: CoreRules -> VarSet
rulesRhsFreeVars (Rules _ fvs) = fvs
rulesRules :: CoreRules -> [CoreRule]
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
The common case
\begin{code}
-type CoreBndr = IdOrTyVar
+type CoreBndr = Var
type CoreExpr = Expr CoreBndr
type CoreArg = Arg CoreBndr
type CoreBind = Bind CoreBndr
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
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)
| 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}
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}
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
\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
-- 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`
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]
| 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)
\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)
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 )
-> (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')
(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)
%************************************************************************
\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)
(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.
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
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
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
)
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
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
-- 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}
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
\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
-- 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
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
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)
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
-- 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
\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
-- 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}
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
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))
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}
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
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
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,
-- 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
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
--
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
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
-- 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
| otherwise -> phase < threshold || has_rules
where
has_rules = v `elemVarSet` rule_vars
- || not (isEmptyCoreRules (getIdSpecialisation v))
+ || not (isEmptyCoreRules (idSpecialisation v))
\end{code}
\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
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
%************************************************************************
\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}
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
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}
\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}
\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
\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
\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}
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*
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}
\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
-- 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
\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}
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)
\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)
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
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}
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)
\begin{code}
initCoreEnv pbdr
= initPprEnv
- (Just ppr) -- Constants
(Just pprCostCentreCore) -- Cost centres
(Just ppr) -- tyvar occs
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 {"),
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 '}'
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]
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
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
-- 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}
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}
* 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:
-- 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
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)
(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
= (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
-- 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
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)
\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)
-- 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.
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"
}
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
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)
| 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
-- 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
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)
cprAnalExpr rho (Type t)
= (Type t, Top)
-
cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
cprAnalCaseAlts rho alts
= foldl anal_alt ([], Bot) 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
-- 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}
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 )
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
\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)]
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,
\begin{code}
module DsCCall
( dsCCall
+ , mkCCall
, unboxArg
, boxResult
, wrapUnboxedValue
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}
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}
= 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
= 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
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]
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]
)
| (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)
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}
`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
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.
-- "_" => 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)
(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))
= 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 ->
= 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 ->
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.
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 ->
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,
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 ->
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
dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
#endif
-out_of_range_msg -- ditto
- = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
\end{code}
%--------------------------------------------------------------------
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
= 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 )
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}
+
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,
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
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)
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
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.
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 ->
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
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 ->
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)
]
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 =
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
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
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 )
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 ->
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] ->
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}
| DoBindMatch
| ListCompMatch
| LetMatch
+ | RecUpdMatch
deriving ()
\end{code}
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
import TysWiredIn ( nilDataCon, consDataCon,
tupleCon,
stringTy,
- unitDataCon, unitTy,
+ unitDataConId, unitTy,
charTy, charDataCon,
intTy, intDataCon,
floatTy, floatDataCon,
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
= 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)]
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
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
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
\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 ])
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}
= 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}
import DsHsSyn ( outPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
-import CoreUtils ( coreExprType )
import DsMonad
import DsGRHSs ( dsGRHSs )
import DsUtils
, 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)
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("=")
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}
import DsMonad
import DsUtils
-import Const ( mkMachInt, Literal(..) )
+import Literal ( mkMachInt, Literal(..) )
import PrimRep ( PrimRep(IntRep) )
import Maybes ( catMaybes )
import Type ( Type, isUnLiftedType )
loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
\end{code}
+
\begin{code}
instance (Outputable id, Outputable pat) =>
Outputable (MonoBinds id pat) where
| DeprecSig (Deprecation name) -- DEPRECATED
SrcLoc
-
data FixitySig name = FixitySig name Fixity SrcLoc
-- We use exported entities for things to deprecate. Cunning trick (hack?):
\begin{code}
module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
- UfBinding(..), UfCon(..),
+ UfBinding(..), UfConAlt(..),
HsIdInfo(..), HsStrictnessInfo(..),
IfaceSig(..), UfRuleBody(..)
) where
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 )
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)
\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)))
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]
| HsUpdate UpdateInfo
| HsSpecialise (UfRuleBody name)
| HsNoCafRefs
- | HsCprInfo CprInfo
+ | HsCprInfo
| HsWorker name -- Worker, if any
instance Outputable name => Outputable (HsIdInfo name) where
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
-- others:
import PprType
import {-# SOURCE #-} FunDeps ( pprFundeps )
+import CStrings ( CLabelString )
import Outputable
import SrcLoc ( SrcLoc )
import Util
#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}
[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}
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
isDataDecl (TyData _ _ _ _ _ _ _ _) = True
isDataDecl other = False
-isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _) = True
-isClassDecl other = False
+isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _ _) = True
+isClassDecl other = False
\end{code}
\begin{code}
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
\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
\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)
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
-- direct from the components
Bool -- boxed?
- | HsCon DataCon -- TRANSLATION; a saturated constructor application
- [Type]
- [HsExpr id pat]
-- Record construction
| RecordCon id -- The constructor
(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
(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
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)
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)
opt_UF_KeenessFactor,
opt_UF_CheapOp,
opt_UF_DearOp,
- opt_UF_NoRepLit,
-- misc opts
opt_CompilingPrelude,
-- 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
= MaxSimplifierIterations Int
| SimplInlinePhase Int
| DontApplyRules
+ | NoCaseOfCase
| SimplLetToCase
\end{code}
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")
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)
= 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
]
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}
%************************************************************************
#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 )
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 >>
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
mAX_SPEC_SELECTEE_SIZE,
mAX_SPEC_AP_SIZE,
- tARGET_MIN_INT, tARGET_MAX_INT,
-
mIN_UPD_SIZE,
mIN_SIZE_NonUpdHeapObject,
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.
-------------------------- 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 -------------------------------
-- 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".)
-------------------------- 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 -------------------------------
= (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))
import CmdLineOpts
import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId,
- getIdSpecialisation
+ idSpecialisation
)
import Var ( isId )
import VarSet
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(..)
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 [
]
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 ()
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 --------------
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
------------ 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)
)
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(..) )
import Util ( naturalMergeSortLe )
import Panic ( panic )
import TyCon ( tyConDataCons )
+import DataCon ( dataConWrapId )
import BitSet ( intBS )
import Name ( NamedThing(..) )
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) )
]
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
intTag :: Literal -> Integer
intTag (MachChar c) = toInteger (ord c)
- intTag (MachInt i _) = i
+ intTag (MachInt i) = i
intTag _ = panic "intTag"
fltTag :: Literal -> Rational
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}
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(..)
import MachRegs
import AbsCSyn hiding (spRel) -- bits and bobs..
-import Const ( Literal(..) )
+import Literal ( Literal(..) )
import CallConv ( cCallConv )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
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 )
\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
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))
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
| ITbottom
| ITinteger_lit
| ITfloat_lit
+ | ITword_lit
+ | ITword64_lit
+ | ITint64_lit
| ITrational_lit
| ITaddr_lit
| ITlit_lit
| ITunfold InlinePragInfo
| ITstrict ([Demand], Bool)
| ITrules
+ | ITcprinfo
| ITdeprecated
- | ITcprinfo (CprInfo)
| IT__scc
| ITsccAllCafs
("__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),
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')
= 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 =
, 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)
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 )
-> 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.
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
-----------------------------------------------------------------------------
{-
-----------------------------------------------------------------------------
-$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.
| {- 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 '#-}'
(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
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 }
| 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 [] }
| fielddecl { [$1] }
fielddecl :: { ([RdrName],RdrNameBangType) }
- : vars '::' stype { (reverse $1, $3) }
+ : sig_vars '::' stype { (reverse $1, $3) }
stype :: { RdrNameBangType }
: ctype { Unbanged $1 }
-----------------------------------------------------------------------------
-- 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)
| 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
| '-' 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
opt_sig :: { Maybe RdrNameHsType }
: {- empty -} { Nothing }
- | '::' type { Just $2 }
+ | '::' sigtype { Just $2 }
opt_asig :: { Maybe RdrNameHsType }
: {- empty -} { Nothing }
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)) }
extractPatsTyVars,
extractRuleBndrsTyVars,
- mkOpApp, mkClassDecl, mkClassOpSig,
+ mkOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
cvBinds,
cvMonoBindsAndSigs,
import HsSyn
import Name ( mkClassTyConOcc, mkClassDataConOcc )
-import OccName ( mkClassTyConOcc, mkClassDataConOcc,
+import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
mkSuperDictSelOcc, mkDefaultMethodOcc
)
import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
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
= 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,
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
, listToBag (map getName wiredInIds)
-- PrimOps
- , listToBag (map (getName . mkPrimitiveId) allThePrimOps)
+ , listToBag (map (getName . mkPrimOpId) allThePrimOps)
-- Thin-air ids
, listToBag thinAirIdNames
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
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 )
import Maybes ( maybeToBool )
import Char ( ord, chr )
import Outputable
-
-#if __GLASGOW_HASKELL__ >= 404
-import GlaExts ( fromInt )
-#endif
\end{code}
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)
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)
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}
%************************************************************************
%* *
%************************************************************************
+ 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
--------------------------
-- 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}
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}
\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
\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}
%************************************************************************
\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)
-- 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
]
= 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)
commutableOp,
- primOpOutOfLine, primOpNeedsWrapper, primOpStrictness,
+ primOpOutOfLine, primOpNeedsWrapper,
primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
primOpHasSideEffects,
getPrimOpResultInfo, PrimOpResultInfo(..),
- pprPrimOp
+ pprPrimOp,
+
+ CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp
) where
#include "HsVersions.h"
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 )
| 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
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)
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
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,
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}
%************************************************************************
%************************************************************************
%* *
-\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#@}
%* *
%************************************************************************
= 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}
\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}
\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}
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}
\begin{code}
primOpNeedsWrapper :: PrimOp -> Bool
-primOpNeedsWrapper (CCallOp _ _ _ _) = True
+primOpNeedsWrapper (CCallOp _) = True
primOpNeedsWrapper Integer2IntOp = True
primOpNeedsWrapper Integer2WordOp = True
-- 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,
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
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)
-- 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)
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
\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
| 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}
doubleTy,
isDoubleTy,
doubleTyCon,
- falseDataCon,
+ falseDataCon, falseDataConId,
floatDataCon,
floatTy,
isFloatTy,
intTy,
intTyCon,
isIntTy,
- inIntRange,
integerTy,
integerTyCon,
-- tuples
mkTupleTy,
- tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon,
+ tupleTyCon, tupleCon, unitTyCon, unitDataConId, pairTyCon,
-- unboxed tuples
mkUnboxedTupleTy,
stablePtrTyCon,
stringTy,
- trueDataCon,
+ trueDataCon, trueDataConId,
unitTy,
voidTy,
wordDataCon,
#include "HsVersions.h"
-import {-# SOURCE #-} MkId( mkDataConId )
+import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId )
-- friends:
import PrelMods
-- 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(..) )
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}
%************************************************************************
unitTyCon = tupleTyCon 0
pairTyCon = tupleTyCon 2
-unitDataCon = tupleCon 0
-pairDataCon = tupleCon 2
+unitDataConId = dataConId (tupleCon 0)
\end{code}
%************************************************************************
= 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}
falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon
trueDataCon = pcDataCon trueDataConKey pREL_BASE SLIT("True") [] [] [] boolTyCon
+
+falseDataConId = dataConId falseDataCon
+trueDataConId = dataConId trueDataCon
\end{code}
%************************************************************************
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 )
import TyCon ( isFunTyCon )
import VarSet
import UniqSet
-import Name ( isLocallyDefinedName )
+import Name ( isLocallyDefined )
import Util ( removeDups )
import Outputable
----------
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
------
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_`
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
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(..),
)
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
'__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 }
'__U' { ITunfold $$ }
'__S' { ITstrict $$ }
'__R' { ITrules }
+ '__M' { ITcprinfo }
'__D' { ITdeprecated }
- '__M' { ITcprinfo $$ }
'..' { ITdotdot } -- reserved symbols
'::' { ITdcolon }
| 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 : { ([],[]) }
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 }
| '__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 }
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 []).
-- 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 ] }
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 }
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 }
| 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 }
| 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
}
)
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
else
let
Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff
+ ExportEnv export_avails _ _ = export_env
in
-- RENAME THE SOURCE
-- 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
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)
(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
-- 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))
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.
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
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)
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)
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(..)
)
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.
-> 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
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
= 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
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) ->
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 []
import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..),
IE(..), ieName,
- ForeignDecl(..), ForKind(..), isDynamic,
+ ForeignDecl(..), ForKind(..), isDynamicExtName,
FixitySig(..), Sig(..), ImportDecl(..),
collectTopBinders
)
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
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}
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' ->
-- 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
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`
= 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
| 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}
%*********************************************************
\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)
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)
= 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' ->
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}
%*********************************************************
= 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}
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
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
-- 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}
+++ /dev/null
-%
-% (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}
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}
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
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:
-- 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
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 ++
\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
-- 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}
\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
-- 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)
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}
#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
%************************************************************************
\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)
} ;
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', _) ->
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') ->
= [ (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
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
--
-- [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}
-> 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)
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 )
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
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}
| 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') ->
= -- 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
= bndr
| otherwise
- = case getIdOccInfo bndr of
+ = case idOccInfo bndr of
OneOcc _ once -> bndr `setIdOccInfo` OneOcc insideLam once
other -> bndr
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
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}
%************************************************************************
%************************************************************************
\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
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}
%************************************************************************
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' ->
-- 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) ->
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)
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
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}
-> 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
`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}
%************************************************************************
\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}
%************************************************************************
\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
-- 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}
\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}
+
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
ratioTyConKey
)
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
-import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
import Util ( mapAccumL )
import SrcLoc ( noSrcLoc )
import Bag
"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 []
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)
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
-- 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}
%************************************************************************
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}
-
-
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_,
#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 )
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,
import Util ( zipWithEqual )
import Outputable
-infixr 9 `thenSmpl`, `thenSmpl_`
+infixr 0 `thenSmpl`, `thenSmpl_`
\end{code}
%************************************************************************
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}
\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
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"
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,
import TysPrim ( statePrimTyCon )
import Var ( setVarUnique )
import VarSet
+import VarEnv ( SubstEnv, SubstResult(..) )
import UniqSupply ( splitUniqSupply, uniqFromSupply )
import Util ( zipWithEqual, mapAccumL )
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}
%* *
%************************************************************************
-- 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
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
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
= 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
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
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}
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
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)
%************************************************************************
\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*
\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.
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
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)
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
-- 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
-- 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' ->
---------------------------------
-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
| 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)
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
etaCoreExprToTrivial rhs | exprIsTrivial rhs' = rhs'
| otherwise = rhs
where
- rhs' = etaCoreExpr rhs
+ rhs' = etaReduceExpr rhs
\end{code}
-- 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}
(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
-- 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')
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
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}
-- 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
-- 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
-- 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}
---------------------------------------------------------
-- 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
tick_case_of_error other = tick BottomFound
\end{code}
+
%************************************************************************
%* *
\subsection{Decisions about inlining}
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
-- 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]
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
-- 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 $
-- 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'
-- 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
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
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
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}
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
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
-- 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')
-- 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 [] [] = []
) `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'))
-- 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' ->
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_`
-- 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)
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'),
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 )
-> 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
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
\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
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) =
| 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 []
import StgSyn
-import Const ( Con(..) )
import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap )
import Id (Id)
\end{code}
\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`
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 )
StgNonRec binder rhs -> [(binder,rhs)]
StgRec pairs -> pairs
- binders' = [ binder `setIdArity` ArityExactly (rhsArity rhs)
+ binders' = [ binder `setIdArityInfo` ArityExactly (rhsArity rhs)
| (binder, rhs) <- pairs
]
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}
= 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}
%************************************************************************
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) ->
-- 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
\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}
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:
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
)
rhsArity (StgRhsClosure _ _ _ _ _ args _) = length args
zapArity :: Id -> Id
-zapArity id = id `setIdArity` UnknownArity
+zapArity id = id `setIdArityInfo` UnknownArity
\end{code}
import VarEnv
import VarSet
import Id ( mkSysLocal,
- getIdUpdateInfo, setIdUpdateInfo, idType,
+ idUpdateInfo, setIdUpdateInfo, idType,
externallyVisibleId,
Id
)
Nothing -> unknownClosure
| otherwise
- = const (case updateInfoMaybe (getIdUpdateInfo v) of
+ = const (case updateInfoMaybe (idUpdateInfo v) of
Nothing -> unknownClosure
Just spec -> convertUpdateSpec spec)
\end{code}
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}
%-----------------------------------------------------------------------------
-> 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
(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}
%-----------------------------------------------------------------------------
#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 )
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 )
\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
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
| 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
= 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}
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)
-- 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}
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 ;
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
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 )
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}
%************************************************************************
---------------- 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) ->
| 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) ->
----------------------------------------------------------
-- 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
calls :: !CallDetails
}
-type DictBind = (CoreBind, IdOrTyVarSet)
+type DictBind = (CoreBind, VarSet)
-- The set is the free vars of the binding
-- both tyvars and dicts
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
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
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
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)
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}
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`
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}
-- 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}
%************************************************************************
\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}
\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}
%************************************************************************
\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
%************************************************************************
\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
-- 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*)
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}
-
%************************************************************************
%* *
%* *
%************************************************************************
-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
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)
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
\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
\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
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
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 _ : _)
(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 } )
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 )
\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_`
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 ->
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_`
(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)
pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs,
getArgPrimRep,
- isLitLitArg,
- stgArity,
+ isLitLitArg, isDynArg, isStgTypeArg,
+ stgArity, stgArgType,
collectFinalStgBinders
#ifdef DEBUG
#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 )
\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}
%************************************************************************
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:[]@.
%************************************************************************
%* *
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)
\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 ]
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 )
\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)
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
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
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...
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,
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.
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
-- 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
-- "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}
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
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}
%* *
%************************************************************************
-@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
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
= 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)!
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
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
#include "HsVersions.h"
import Id ( Id )
+import Type ( Type )
import CoreSyn ( CoreExpr )
import VarEnv
import IdInfo ( StrictnessInfo(..) )
-- 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
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}
%-----------
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}
-> 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
-- 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
-- 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}
%************************************************************************
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
-- 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
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
-- 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
:: 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}
%************************************************************************
| isTyVar var = (tot, demanded)
| otherwise
= (tot + 1,
- if (isStrict (getIdDemandInfo var))
+ if (isStrict (idDemandInfo var))
then demanded + 1
else demanded)
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}
#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
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 ->
-- 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
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
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
#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 )
-> 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
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}
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
%************************************************************************
\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:
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}
%************************************************************************
\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
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))
returnUs (arg : worker_args, wrap_fn, work_fn)
| otherwise
- = case getIdDemandInfo arg of
+ = case idDemandInfo arg of
-- Absent case
WwLazy True ->
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] ->
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
(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}
-- 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
(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
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 )
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
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 ->
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.
| 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 ->
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
\section[TcClassDcl]{Typechecking class declarations}
\begin{code}
-module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2,
+module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, mkImplicitClassBinds,
tcMethodBind, checkFromThisClass
) where
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,
)
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(..) )
\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_`
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 _ ->
[{-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)
-> 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)
| 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}
%************************************************************************
#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,
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 ->
mkMonoBind, nullMonoBinds
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
-import TcHsSyn ( TcExpr, TcRecordBinds,
+import TcHsSyn ( TcExpr, TcRecordBinds, mkHsConApp,
mkHsTyApp, mkHsLet, maybeBoxedPrimType
)
isRecordSelector,
Id, mkVanillaId
)
-import DataCon ( dataConFieldLabels, dataConSig, dataConId,
+import DataCon ( dataConFieldLabels, dataConSig,
dataConStrictMarks, StrictnessMark(..)
)
import Name ( Name, getName )
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 ->
-- 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}
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
#include "HsVersions.h"
import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
- ExtName(..), isDynamic, MonoBinds(..),
+ ExtName(Dynamic), isDynamicExtName, MonoBinds(..),
OutPat(..), ForKind(..)
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
-- 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}
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))
TypecheckedGRHSs, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
- mkHsTyApp, mkHsDictApp,
+ mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
+ idsToMonoBinds,
-- re-exported from TcEnv
TcId, tcInstId,
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
)
import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList )
import VarSet ( isEmptyVarSet )
import CoreSyn ( Expr )
+import CoreUnfold( unfoldingTemplate )
import BasicTypes ( RecFlag(..) )
import Bag
import UniqFM
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}
%************************************************************************
= 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 ->
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 ->
)
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 )
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' ->
-- 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
= 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
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
= 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)
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'] $
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}
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)
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}
andMonoBindList
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
-import TcHsSyn ( TcMonoBinds,
+import TcHsSyn ( TcMonoBinds, mkHsConApp,
maybeBoxedPrimType
)
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 )
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]
(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
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,
import TcInstUtil ( buildInstanceEnvs, classDataCon, InstInfo )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
-import TcTyDecls ( mkDataBinds )
+import TcTyDecls ( mkImplicitDataBinds )
import TcType ( TcType, typeToTcType,
TcKind, kindToTcKind,
newTyVarTy
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 )
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
-- (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
-- 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) ->
-- 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
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,
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 ->
-- 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
-- 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}
= 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
;
- 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
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")
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),
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
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))
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
----------------------------------------------------
module TcTyDecls (
tcTyDecl, kcTyDecl,
tcConDecl,
- mkDataBinds
+ mkImplicitDataBinds
) where
#include "HsVersions.h"
andMonoBindList
)
import RnHsSyn ( RenamedTyClDecl, RenamedConDecl )
-import TcHsSyn ( TcMonoBinds )
+import TcHsSyn ( TcMonoBinds, idsToMonoBinds )
import BasicTypes ( RecFlag(..), NewOrData(..) )
import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope,
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 )
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_`
\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]
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
%************************************************************************
\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
]
-- 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}
\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}
isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon,
isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon,
+ isRecursiveTyCon,
mkAlgTyCon,
mkFunTyCon,
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
isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = False}) = True
isUnboxedTupleTyCon other = False
+
+isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True
+isRecursiveTyCon other = False
\end{code}
\begin{code}
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,
-- Lifting and boxity
isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
- typePrimRep,
-- Free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
-- 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
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
interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
+ Representation types
+ ~~~~~~~~~~~~~~~~~~~~
repType looks through
(a) for-alls, and
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
-- 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}
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}
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}
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 )
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
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 )
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
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)
-- 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
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 )
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
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')
-- 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')
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')
#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
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}
-> 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
-> 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
; 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
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)
\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
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))
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
\begin{code}
module Maybes (
--- Maybe(..), -- no, it's in 1.3
+ Maybe2(..), Maybe3(..),
MaybeErr(..),
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}
%* *
%************************************************************************
failMaB :: err -> MaybeErr val err
failMaB e = Failed e
\end{code}
+
-- 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
-- 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,
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
\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}
$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;
'-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',
# 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',
# 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.
#
,'-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"
));
# 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 {
# ---------------
- /^-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
# ---------------
/* -----------------------------------------------------------------------------
- * $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
*
#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;
* 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
/* -----------------------------------------------------------------------------
- * $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
*
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 \
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 \
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 \
%*********************************************************
%* *
+\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@}
%* *
%*********************************************************
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
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
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 }
\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
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
#-}
----------------------------------------------
\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
\begin{code}
unpackCString# :: Addr# -> [Char]
-{-# INLINE unpackCString# #-}
-unpackCString# a = build (unpackFoldrCString# a)
+unpackCString# a = unpackCStringList# a
unpackCStringList# :: Addr# -> [Char]
unpackCStringList# addr
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
-- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n
#-}
+
\end{code}
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#
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
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}
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
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}
% -----------------------------------------------------------------------------
-% $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
%
\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}
#include "../includes/ieee-flpt.h"
-module PrelFloat where
+module PrelFloat( module PrelFloat, Float#, Double# ) where
import {-# SOURCE #-} PrelErr
import PrelBase
ZLzmzgZR -- (->)
- All -- Pseudo class used for universal quantification
CCallable
CReturnable
zpzh
zmzh
ztzh
- zszh
quotIntzh
remIntzh
gcdIntzh
\begin{code}
{-# INLINE newHandle #-}
-{-# INLINE withHandle #-}
newHandle :: Handle__ -> IO Handle
-- Use MVars for concurrent Haskell
\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)
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)
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)
-- 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
#-}
-- 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
\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
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}
\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
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}
{-# 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
go x | x < lim = []
| otherwise = x : go (x+delta)
-{-# RULES
-"enumDeltaInteger" enumDeltaIntegerFB (:) = enumDeltaIntegerList
-"enumDeltaToInteger" enumDeltaToIntegerFB (:) [] = enumDeltaToIntegerList
- #-}
\end{code}
; 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
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
/* -----------------------------------------------------------------------------
- * $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
*
*/
#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;
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)
/* 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;
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
-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 }
--- /dev/null
+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]))
+
+
--- /dev/null
+[(0,1),(1,2),(2,3),(3,4)]
\ No newline at end of file
+-- 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
((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
--- !!! 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
__export ShouldSucceed f;
-1 f :: __forall [a] => {PrelNum.Num a} -> {PrelBase.Eq a} -> [a] -> [a] ;
+1 f :: __forall [a] => {PrelNum.Num a} -> [a] -> [a] ;
__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 ;
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} ;
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]} ;
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} ;
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} ;
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} ;
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} ;
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) ;
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 ;
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 ;
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
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
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:
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
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)
projects / ghc-hetmet.git / commitdiff