# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.5 1996/12/19 09:10:03 simonpj Exp $
+# $Id: Makefile,v 1.6 1997/01/06 21:08:42 simonpj Exp $
TOP = ../..
FlexSuffixRules = YES
all :: hsc libhsp.a
hsc : $(OBJS)
-# $(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) -o $@ $^
- $(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) -o $@ $^
-# $(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) -o $@ $^
+# $(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^
+ $(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^
+# $(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^
parser/hschooks.o : parser/hschooks.c
@$(RM) $@
rename/ParseIface.hs : rename/ParseIface.y
@$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
- happy +RTS -K2m -RTS -g rename/ParseIface.y
+ happy +RTS -K2m -H10m -RTS -g rename/ParseIface.y
@chmod 444 rename/ParseIface.hs
# ----------------------------------------------------------------------------
|| (c >= '0' && c <= '9')
then [c]
else case c of
- _ -> '\\' : 'o' : (octify (ord c))
+ _ -> '\\' : show (ord c)
octify :: Int -> String
octify n
recordSelectorFieldLabel,
-- PREDICATES
- wantIdSigInIface,
+ omitIfaceSigForId,
cmpEqDataCon,
cmpId,
cmpId_withSpecDataCon,
import IdInfo
import Maybes ( maybeToBool )
import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName,
- mkCompoundName, mkInstDeclName, mkWiredInIdName, mkGlobalName,
+ mkCompoundName, mkInstDeclName,
isLocallyDefinedName, occNameString, modAndOcc,
isLocallyDefined, changeUnique, isWiredInName,
nameString, getOccString, setNameVisibility,
chk (SpecPragmaId _ no_free_tvs) = no_free_tvs
chk (PrimitiveId _) = True
--- wantIdSigInIface decides whether to put an Id's type signature and
--- IdInfo in an interface file
-wantIdSigInIface
- :: Bool -- True <=> the thing is mentioned somewhere else in the
- -- interface file
- -> Bool -- True <=> omit anything that doesn't *have* to go
- -> Id
+-- omitIfaceSigForId tells whether an Id's info is implied by other declarations,
+-- so we don't need to put its signature in an interface file, even if it's mentioned
+-- in some other interface unfolding.
+
+omitIfaceSigForId
+ :: Id
-> Bool
-wantIdSigInIface mentioned_already omit_iface_prags (Id _ name _ details _ _)
- = chk details
- where
- chk (LocalId _) = isExported name &&
- not (isWiredInName name) -- User-declared thing!
- chk ImportedId = False -- Never put imports in interface file
- chk (PrimitiveId _) = False -- Ditto, for primitives
+omitIfaceSigForId (Id _ name _ details _ _)
+ | isWiredInName name
+ = True
+
+ | otherwise
+ = case details of
+ ImportedId -> True -- Never put imports in interface file
+ (PrimitiveId _) -> True -- Ditto, for primitives
-- This group is Ids that are implied by their type or class decl;
- -- remember that all type and class decls appear in the interface file
- chk (DataConId _ _ _ _ _ _ _) = False
- chk (TupleConId _) = False -- Ditto
- chk (RecordSelId _) = False -- Ditto
- chk (SuperDictSelId _ _) = False -- Ditto
- chk (MethodSelId _ _) = False -- Ditto
- chk (ConstMethodId _ _ _ _) = False -- Scheduled for nuking
- chk (DefaultMethodId _ _ _) = False -- Hmm. No, for now
-
- -- DictFunIds are more interesting, they may have IdInfo we can't
- -- get from the instance declaration. We emit them if we're gung ho.
- -- No need to check the export flag; instance decls are always exposed
- chk (DictFunId _ _) = not omit_iface_prags
-
- -- This group are only called out by being mentioned somewhere else
- chk (WorkerId unwrkr) = mentioned_already
- chk (SpecId _ _ _) = mentioned_already
- chk (InstId _) = mentioned_already
- chk (SysLocalId _) = mentioned_already
- chk (SpecPragmaId _ _) = mentioned_already
+ -- 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
+ (DataConId _ _ _ _ _ _ _) -> True
+ (TupleConId _) -> True
+ (RecordSelId _) -> True
+ (SuperDictSelId _ _) -> True
+ (MethodSelId _ _) -> True
+
+ other -> False -- Don't omit!
+ -- NB DefaultMethodIds are not omitted
\end{code}
\begin{code}
addStrictnessInfo (IdInfo a b d _ e f g h i) strict = IdInfo a b d strict e f g h i
ppStrictnessInfo sty NoStrictnessInfo = ppNil
-ppStrictnessInfo sty BottomGuaranteed = ppPStr SLIT("_S_ _!_")
+ppStrictnessInfo sty BottomGuaranteed = ppPStr SLIT("_bot_")
ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe)
= ppCat [ppPStr SLIT("_S_"), ppStr (showList wrapper_args ""), pp_wrkr]
import CStrings ( stringToC, charToC, charToEasyHaskell )
import TysWiredIn ( stringTy )
import Pretty -- pretty-printing stuff
-import PprStyle ( PprStyle(..), codeStyle )
-import Util ( thenCmp, panic )
+import PprStyle ( PprStyle(..), codeStyle, ifaceStyle )
+import Util ( thenCmp, panic, pprPanic )
\end{code}
So-called @Literals@ are {\em either}:
data Literal
= MachChar Char
| MachStr FAST_STRING
+
| MachAddr Integer -- whatever this machine thinks is a "pointer"
+
| MachInt Integer -- for the numeric types, these are
Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
+
| MachFloat Rational
| MachDouble Rational
+
| MachLitLit FAST_STRING
PrimRep
- | NoRepStr FAST_STRING -- the uncommitted ones
- | NoRepInteger Integer Type{-save what we learned in the typechecker-}
- | NoRepRational Rational Type{-ditto-}
+ | NoRepStr FAST_STRING
+ | NoRepInteger Integer Type -- This Type is always Integer
+ | NoRepRational Rational Type -- This Type is always Rational
+ -- We keep these Types in the literal because Rational isn't
+ -- (currently) wired in, so we can't conjure up its type out of
+ -- thin air. Integer is, so the type here is really redundant.
-- deriving (Eq, Ord): no, don't want to compare Types
-- The Ord is needed for the FiniteMap used in the lookForConstructor
ppCast PprForC cast = ppPStr cast
ppCast _ _ = ppNil
+-- MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
+-- exceptions: MachFloat and MachAddr get an initial keyword prefix
+--
+-- NoRep things get an initial keyword prefix (e.g. _integer_ 3)
+
instance Outputable Literal where
ppr sty (MachChar ch)
= let
= case sty of
PprForC -> charToC ch
PprForAsm _ _ -> charToC ch
- PprUnfolding -> charToEasyHaskell ch
+ PprInterface -> charToEasyHaskell ch
_ -> [ch]
in
- ppBeside (ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\''])
- (if_ubxd sty)
+ ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\'']
ppr sty (MachStr s)
- = ppBeside (if codeStyle sty
- then ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"']
- else ppStr (show (_UNPK_ s)))
- (if_ubxd sty)
+ | codeStyle sty = ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"']
+ | otherwise = ppStr (show (_UNPK_ s))
+
+ ppr sty lit@(NoRepStr s)
+ | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
+ | otherwise = ppBesides [ppStr "_string_", ppStr (show (_UNPK_ s))]
- ppr sty (MachAddr p) = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p, if_ubxd sty]
ppr sty (MachInt i signed)
- | codeStyle sty
- && ((signed && (i >= toInteger minInt && i <= toInteger maxInt))
- || (not signed && (i >= toInteger 0 && i <= toInteger maxInt)))
- -- ToDo: Think about these ranges!
- = ppBesides [ppInteger i, if_ubxd sty]
-
- | not (codeStyle sty) -- we'd prefer the code to the error message
- = ppBesides [ppInteger i, if_ubxd sty]
-
- | otherwise
- = error ("ERROR: Int " ++ show i ++ " out of range [" ++
- show range_min ++ " .. " ++ show maxInt ++ "]\n")
+ | codeStyle sty && out_of_range
+ = panic ("ERROR: Int " ++ show i ++ " out of range [" ++
+ show range_min ++ " .. " ++ show range_max ++ "]\n")
+
+ | otherwise = ppInteger 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)
- ppr sty (MachFloat f) = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f, if_ubxd sty]
- ppr sty (MachDouble d) = ppBesides [ppRational d, if_ubxd sty, if_ubxd sty]
-
- ppr sty (NoRepInteger i _)
- | codeStyle sty = ppInteger i
- | ufStyle sty = ppCat [ppStr "_NOREP_I_", ppInteger i]
- | otherwise = ppBesides [ppInteger i, ppChar 'I']
+ ppr sty (MachFloat f)
+ | codeStyle sty = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f]
+ | otherwise = ppBesides [ppStr "_float_", ppRational f]
- ppr sty (NoRepRational r _)
- | ufStyle sty = ppCat [ppStr "_NOREP_R_", ppInteger (numerator r), ppInteger (denominator r)]
- | codeStyle sty = panic "ppr.ForC.NoRepRational"
- | otherwise = ppBesides [ppRational r, ppChar 'R']
+ ppr sty (MachDouble d) = ppRational d
- ppr sty (NoRepStr s)
- | codeStyle sty = ppBesides [ppStr (show (_UNPK_ s))]
- | ufStyle sty = ppCat [ppStr "_NOREP_S_", ppStr (show (_UNPK_ s))]
- | otherwise = ppBesides [ppStr (show (_UNPK_ s)), ppChar 'S']
+ ppr sty (MachAddr p)
+ | codeStyle sty = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p]
+ | otherwise = ppBesides [ppStr "_addr_", ppInteger p]
- ppr sty (MachLitLit s k)
- | codeStyle sty = ppPStr s
- | ufStyle sty = ppBesides [ppStr "``", ppPStr s, ppStr "'' _K_ ", ppr sty k]
- | otherwise = ppBesides [ppStr "``", ppPStr s, ppStr "''"]
+ ppr sty lit@(NoRepInteger i _)
+ | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
+ | otherwise = ppCat [ppStr "_integer_", ppInteger i]
-ufStyle PprUnfolding = True
-ufStyle _ = False
+ ppr sty lit@(NoRepRational r _)
+ | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
+ | otherwise = ppCat [ppStr "_rational_", ppInteger (numerator r), ppInteger (denominator r)]
-if_ubxd sty = if codeStyle sty then ppNil else ppChar '#'
+ ppr sty (MachLitLit s k)
+ | codeStyle sty = ppPStr s
+ | otherwise = ppBesides [ppStr "_litlit_", ppStr (show (_UNPK_ s))]
showLiteral :: PprStyle -> Literal -> String
-
showLiteral sty lit = ppShow 80 (ppr sty lit)
\end{code}
+
import CgMonad
import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
-import CLabel ( mkClosureLabel )
+import CLabel ( mkStaticClosureLabel, mkClosureLabel )
import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo )
import HeapOffs ( SYN_IE(VirtualHeapOffset),
SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset)
getArgAmode :: StgArg -> FCode CAddrMode
-getArgAmode (StgVarArg var) = getCAddrMode var
+getArgAmode (StgConArg var)
+ {- 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 var) (idPrimRep var))
+
+getArgAmode (StgVarArg var) = getCAddrMode var -- The common case
+
getArgAmode (StgLitArg lit) = returnFC (CLit lit)
\end{code}
\item Adjust the stack high water mark appropriately.
\end{itemize}
+\begin{code}
+cgTailCall (StgConArg con) args live_vars
+ = panic "cgTailCall StgConArg" -- Only occur in argument positions
+\end{code}
+
Literals are similar to constructors; they return by putting
themselves in an appropriate register and returning to the address on
top of the B stack.
)
import CLabel ( mkStdEntryLabel, mkFastEntryLabel,
mkPhantomInfoTableLabel, mkInfoTableLabel,
- mkConInfoTableLabel,
+ mkConInfoTableLabel, mkStaticClosureLabel,
mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
mkStaticInfoTableLabel, mkStaticConEntryLabel,
mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
_ -> mkConEntryLabel con
-closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id
+closureLabelFromCI (MkClosureInfo id _ rep)
+ | isConstantRep rep
+ = mkStaticClosureLabel id
+ -- This case catches those pesky static closures for nullary constructors
+
+closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id
entryLabelFromCI :: ClosureInfo -> CLabel
entryLabelFromCI (MkClosureInfo id lf_info rep)
calcUnfoldingGuidance True bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
+calcUnfoldingGuidance False any_size (Con _ _ ) = UnfoldAlways -- We are very gung ho about inlining
+calcUnfoldingGuidance False any_size (Lit _) = UnfoldAlways -- constructors and literals
+
calcUnfoldingGuidance False bOMB_OUT_SIZE expr
= let
(use_binders, ty_binders, val_binders, body) = collectBinders expr
-> Bool -- True => it's small enough to inline
-> Bool -- True => yes, inline it
--- Always inline bottoms
-okToInline BottomForm occ_info small_enough
- = True -- Unless one of the type args is unboxed??
- -- This used to be checked for, but I can't
- -- see why so I've left it out.
-
--- A WHNF can be inlined if it occurs once, or is small
+-- If there's no danger of duplicating work, we can inline if it occurs once, or is small
okToInline form occ_info small_enough
- | is_whnf_form form
+ | no_dup_danger form
= small_enough || one_occ
where
one_occ = case occ_info of
OneOcc _ _ _ n_alts _ -> n_alts <= 1
other -> False
- is_whnf_form VarForm = True
- is_whnf_form ValueForm = True
- is_whnf_form other = False
+ no_dup_danger VarForm = True
+ no_dup_danger ValueForm = True
+ no_dup_danger BottomForm = True
+ no_dup_danger other = False
-- A non-WHNF can be inlined if it doesn't occur inside a lambda,
-- and occurs exactly once or
SYN_IE(UniqSM), UniqSupply
)
import Usage ( SYN_IE(UVar) )
-import Util ( zipEqual, panic, pprPanic, assertPanic )
+import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic )
+import Pretty
+import Outputable ( Outputable(..) )
type TypeEnv = TyVarEnv Type
applyUsage = panic "CoreUtils.applyUsage:ToDo"
-- a Con is a fully-saturated application of a data constructor
-- a Prim is <ditto> of a PrimOp
-coreExprType (Con con args) = applyTypeToArgs (dataConRepType con) args
+coreExprType (Con con args) =
+-- pprTrace "appTyArgs" (ppCat [ppr PprDebug con, ppSemi,
+-- ppr PprDebug con_ty, ppSemi,
+-- ppr PprDebug args]) $
+ applyTypeToArgs con_ty args
+ where
+ con_ty = dataConRepType con
+
coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
coreExprType (Lam (ValBinder binder) expr)
= mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
coreExprType (App expr (TyArg ty))
- = applyTy (coreExprType expr) ty
+ =
+-- pprTrace "appTy1" (ppCat [ppr PprDebug fun_ty, ppSP, ppr PprDebug ty]) $
+ applyTy fun_ty ty
+ where
+ fun_ty = coreExprType expr
coreExprType (App expr (UsageArg use))
= applyUsage (coreExprType expr) use
import Outputable -- quite a few things
import PprEnv
import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
-import PprStyle ( PprStyle(..) )
+import PprStyle ( PprStyle(..), ifaceStyle )
import Pretty
import PrimOp ( PrimOp{-instances-} )
import TyVar ( GenTyVar{-instances-} )
init_ppr_env sty tvbndr pbdr1 pbdr2 pocc
= initPprEnv sty
(Just (ppr sty)) -- literals
- (Just (ppr sty)) -- data cons
- (Just (ppr sty)) -- primops
+ (Just ppr_con) -- data cons
+ (Just ppr_prim) -- primops
(Just (\ cc -> ppStr (showCostCentre sty True cc)))
- (Just tvbndr) -- tyvar binders
- (Just (ppr sty)) -- tyvar occs
- (Just (ppr sty)) -- usage vars
+ (Just tvbndr) -- tyvar binders
+ (Just (ppr sty)) -- tyvar occs
+ (Just (ppr sty)) -- usage vars
(Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
(Just (pprParendGenType sty)) -- types
- (Just (ppr sty)) -- usages
+ (Just (ppr sty)) -- usages
+ where
+ -- ppr_con is used when printing Con expressions; we add a "!"
+ -- to distinguish them from ordinary applications. But not when
+ -- printing for interfaces, where they are treated as ordinary applications
+ ppr_con con | ifaceStyle sty = ppr sty con
+ | otherwise = ppr sty con `ppBeside` ppChar '!'
+
+ -- We add a "!" to distinguish Primitive applications from ordinary applications.
+ -- But not when printing for interfaces, where they are treated
+ -- as ordinary applications
+ ppr_prim prim | ifaceStyle sty = ppr sty prim
+ | otherwise = ppr sty prim `ppBeside` ppChar '!'
--------------
pprCoreBinding sty (NonRec binder expr)
ppr_expr pe (Con con []) = pCon pe con
ppr_expr pe (Con con args)
- = ppHang (ppBesides [pCon pe con, ppChar '!'])
+ = ppHang (pCon pe con)
4 (ppSep (map (ppr_arg pe) args))
ppr_expr pe (Prim prim args)
- = ppHang (ppBesides [pPrim pe prim, ppChar '!'])
+ = ppHang (pPrim pe prim)
4 (ppSep (map (ppr_arg pe) args))
ppr_expr pe expr@(Lam _ _)
pp_vars lam pp vs
= ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
-ppr_expr pe expr@(App _ _)
+ppr_expr pe expr@(App fun arg)
= let
- (fun, uargs, targs, vargs) = collectArgs expr
+ (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)
in
- ppHang (ppr_parend_expr pe fun)
- 4 (ppSep [ ppInterleave ppNil (map (pUse pe) uargs)
- , ppInterleave ppNil (map (pTy pe) targs)
- , ppInterleave ppNil (map (ppr_arg pe) vargs)
- ])
+ ppHang (ppr_parend_expr pe final_fun) 4 (ppSep (map (ppr_arg pe) final_args))
ppr_expr pe (Case expr alts)
| only_one_alt alts
ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->")
ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
- = ppCat [ppr_alt_con con (pCon pe con),
+ = ppCat [pCon pe con,
ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"]
ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
in
ppSep
- [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts],
- ppBeside (ppr_rhs alts) (ppStr ";}")]
+ [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts],
+ ppBeside (ppr_rhs alts) (ppStr ";}")]
| otherwise -- default "case" printing
= ppSep
- [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {"],
+ [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {"],
ppNest 2 (ppr_alts pe alts),
ppStr "}"]
+ where
+ pp_keyword = case alts of
+ AlgAlts _ _ -> ppPStr SLIT("case")
+ PrimAlts _ _ -> ppPStr SLIT("case#")
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
ppr_parend_expr pe expr ]
ppr_expr pe (Coerce c ty expr)
- = ppSep [pp_coerce c, pTy pe ty, ppr_parend_expr pe expr ]
+ = ppSep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
where
- pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_") (ppr (pStyle pe) v)
- pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_") (ppr (pStyle pe) v)
+ pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_ ") (ppr (pStyle pe) v)
+ pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_ ") (ppr (pStyle pe) v)
only_one_alt (AlgAlts [] (BindDefault _ _)) = True
only_one_alt (AlgAlts (_:[]) NoDefault) = True
only_one_alt (PrimAlts [] (BindDefault _ _)) = True
only_one_alt (PrimAlts (_:[]) NoDefault) = True
only_one_alt _ = False
-
-ppr_alt_con con pp_con = if parenInCode (getOccName con) then ppParens pp_con else pp_con
\end{code}
\begin{code}
ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
ppStr "->"]
else
- ppCat [ppr_alt_con con (pCon pe con),
+ ppCat [pCon pe con,
ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"]
)
\begin{code}
ppr_arg pe (LitArg lit) = pLit pe lit
ppr_arg pe (VarArg v) = pOcc pe v
-ppr_arg pe (TyArg ty) = pTy pe ty
+ppr_arg pe (TyArg ty) = ppStr "@ " `ppBeside` pTy pe ty
ppr_arg pe (UsageArg use) = pUse pe use
\end{code}
\begin{code}
unboxArg :: CoreExpr -- The supplied argument
- -> DsM (CoreExpr, -- To pass as the actual argument
+ -> DsM (CoreExpr, -- To pass as the actual argument
CoreExpr -> CoreExpr -- Wrapper to unbox the arg
)
unboxArg arg
-- Primitive types
-- ADR Question: can this ever be used? None of the PrimTypes are
-- instances of the CCallable class.
+ --
+ -- SOF response:
+ -- Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
+ -- that accept unboxed arguments is a Good Thing if you have a stub generator
+ -- which generates the boiler-plate box-unbox code for you, i.e., it may help
+ -- us nuke this very module :-)
+ --
| isPrimType arg_ty
= returnDs (arg, \body -> body)
mkConDs (tupleCon (length expr_list))
(map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs)
--- Two cases, one for ordinary constructors and one for newtype constructors
-dsExpr (HsCon con tys args)
- | isDataTyCon tycon -- The usual datatype case
- = mapDs dsExpr args `thenDs` \ args_exprs ->
- mkConDs con (map TyArg tys ++ map VarArg args_exprs)
-
- | otherwise -- The newtype case
- = ASSERT( isNewTyCon tycon )
- ASSERT( null rest_args )
- dsExpr first_arg `thenDs` \ arg_expr ->
- returnDs (Coerce (CoerceIn con) result_ty arg_expr)
-
- where
- (first_arg:rest_args) = args
- (args_tys, result_ty) = splitFunTy (foldl applyTy (idType con) tys)
- (tycon,_) = getAppTyCon result_ty
-
dsExpr (ArithSeqOut expr (From from))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id))
dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals)
- = panic "dfListComp:LetQual"
+ -- new in 1.3, local bindings
+ = dsBinds False binds `thenDs` \ core_binds ->
+ dfListComp expr expr_ty c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
+ returnDs ( mkCoLetsAny core_binds core_rest )
dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals)
-- evaluate the two lists
after = if is_casm then ppStr "'' " else ppSP
in
ppBesides [before, ppPStr str, after,
- ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
+ ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
ppr sty (UfOtherOp op)
= ppr sty op
| SingleDict -- a simple special case of Dictionary
id -- local dictionary name
- | HsCon -- TRANSLATION; a constructor application
- Id -- used only in the RHS of constructor definitions
- [GenType tyvar uvar]
- [HsExpr tyvar uvar id pat]
-
type HsRecordBinds tyvar uvar id pat
= [(id, HsExpr tyvar uvar id pat, Bool)]
-- True <=> source code used "punning",
pprExpr sty (SingleDict dname)
= ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname]
-pprExpr sty (HsCon con tys exprs)
- = ppCat [ppPStr SLIT("{-HsCon-}"), ppr sty con, interppSP sty tys, interppSP sty exprs]
\end{code}
Parenthesize unless very simple:
opt_D_verbose_stg2stg,
opt_DoCoreLinting,
opt_DoSemiTagging,
+ opt_DoEtaReduction,
opt_DoTickyProfiling,
opt_EnsureSplittableC,
opt_FoldrBuildOn,
opt_IrrefutableEverything,
opt_IrrefutableTuples,
opt_LiberateCaseThreshold,
+ opt_NoImplicitPrelude,
opt_NumbersStrict,
opt_OmitBlackHoling,
opt_OmitDefaultInstanceMethods,
| IgnoreINLINEPragma
| SimplDoLambdaEtaExpansion
- | SimplDoEtaReduction
| EssentialUnfoldingsOnly -- never mind the thresholds, only
-- do unfoldings that *must* be done
opt_DoCoreLinting = lookUp SLIT("-dcore-lint")
opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging")
opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky")
+opt_DoEtaReduction = lookUp SLIT("-fdo-eta-reduction")
opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names")
opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on")
opt_FoldrBuildTrace = lookUp SLIT("-ffoldr-build-trace")
opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas")
opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything")
opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples")
+opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude")
opt_NumbersStrict = lookUp SLIT("-fnumbers-strict")
opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing")
opt_OmitDefaultInstanceMethods = lookUp SLIT("-fomit-default-instance-methods")
"-ffloat-primops-ok" -> SIMPL_SW(SimplOkToFloatPrimOps)
"-falways-float-lets-from-lets" -> SIMPL_SW(SimplAlwaysFloatLetsFromLets)
"-fdo-case-elim" -> SIMPL_SW(SimplDoCaseElim)
- "-fdo-eta-reduction" -> SIMPL_SW(SimplDoEtaReduction)
"-fdo-lambda-eta-expansion" -> SIMPL_SW(SimplDoLambdaEtaExpansion)
"-fdo-foldr-build" -> SIMPL_SW(SimplDoFoldrBuild)
"-fdo-not-fold-back-append" -> SIMPL_SW(SimplDontFoldBackAppend)
tagOf_SimplSwitch SimplDoInlineFoldrBuild = ILIT(14)
tagOf_SimplSwitch IgnoreINLINEPragma = ILIT(15)
tagOf_SimplSwitch SimplDoLambdaEtaExpansion = ILIT(16)
-tagOf_SimplSwitch SimplDoEtaReduction = ILIT(18)
tagOf_SimplSwitch EssentialUnfoldingsOnly = ILIT(19)
tagOf_SimplSwitch ShowSimplifierProgress = ILIT(20)
tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(21)
STGFUN(_regDsLoop){}
STGFUN(_regIdLoop){}
STGFUN(_regPrelLoop){}
+STGFUN(_regSmplLoop){}
STGFUN(_regTyLoop){}
STGFUN(_regHsLoop){}
STGFUN(_regSpecLoop){}
STGFUN(_regTcMLoop){}
STGFUN(_regTcLoop){}
STGFUN(_regRnLoop){}
+STGFUN(_regCgLoop1){}
+STGFUN(_regCgLoop2){}
\end{code}
doDump opt_D_dump_deriv "Derived instances:"
(pp_show (ddump_deriv pprStyle)) >>
- -- Now (and alas only now) we have the derived-instance information
- -- so we can put instance information in the interface file
- ifaceInstances if_handle inst_info >>
-
-- ******* DESUGARER
show_pass "DeSugar " >>
_scc_ "DeSugar"
(pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2)))
>>
- -- Dump type signatures into the interface file
+ -- Dump instance decls and type signatures into the interface file
let
final_ids = collectFinalStgBinders stg_binds2
in
- ifaceDecls if_handle rn_mod final_ids simplified >>
- endIface if_handle >>
+ ifaceDecls if_handle rn_mod inst_info final_ids simplified >>
+ endIface if_handle >>
-- We are definitely done w/ interface-file stuff at this point:
-- (See comments near call to "startIface".)
module MkIface (
startIface, endIface,
- ifaceMain, ifaceInstances,
+ ifaceMain,
ifaceDecls
) where
import CmdLineOpts
import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
- getIdInfo, idWantsToBeINLINEd, wantIdSigInIface,
+ getIdInfo, idWantsToBeINLINEd, omitIfaceSigForId,
dataConStrictMarks, StrictnessMark(..),
SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet,
isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
import Bag ( bagToList )
import Maybes ( catMaybes, maybeToBool )
-import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
+import FiniteMap ( emptyFM, addToFM, addToFM_C, lookupFM, fmToList, eltsFM, FiniteMap )
import UniqFM ( UniqFM, lookupUFM, listToUFM )
import Util ( sortLt, zipWithEqual, zipWith3Equal, mapAccumL,
assertPanic, panic{-ToDo:rm-}, pprTrace )
-> InterfaceDetails
-> IO ()
-ifaceInstances :: Maybe Handle -> Bag InstInfo -> IO ()
ifaceDecls :: Maybe Handle
-> RenamedHsModule
+ -> Bag InstInfo
-> [Id] -- Ids used at code-gen time; they have better pragma info!
-> [CoreBinding] -- In dependency order, later depend on earlier
-> IO ()
ifaceFixities if_hdl fixities >>
return ()
-ifaceDecls Nothing rn_mod final_ids simplified = return ()
-ifaceDecls (Just hdl)
+ifaceDecls Nothing rn_mod inst_info final_ids simplified = return ()
+ifaceDecls (Just hdl)
(HsModule _ _ _ _ _ decls _)
+ inst_infos
final_ids binds
| null decls = return ()
-- You could have a module with just (re-)exports/instances in it
| otherwise
- = hPutStr hdl "_declarations_\n" >>
- ifaceTCDecls hdl decls >>
- ifaceBinds hdl final_ids binds >>
+ = ifaceInstances hdl inst_infos >>= \ needed_ids ->
+ hPutStr hdl "_declarations_\n" >>
+ ifaceTCDecls hdl decls >>
+ ifaceBinds hdl needed_ids final_ids binds >>
return ()
\end{code}
ifaceExports if_hdl [] = return ()
ifaceExports if_hdl avails
= hPutStr if_hdl "_exports_\n" >>
- hPutCol if_hdl upp_avail (sortLt lt_avail avails)
+ hPutCol if_hdl do_one_module (fmToList export_fm)
+ where
+ -- Sort them into groups by module
+ export_fm :: FiniteMap Module [AvailInfo]
+ export_fm = foldr insert emptyFM avails
+ insert avail@(Avail name _) efm = addToFM_C (++) efm mod [avail]
+ where
+ (mod,_) = modAndOcc name
+ insert NotAvailable efm = efm
+
+ -- Print one module's worth of stuff
+ do_one_module (mod_name, avails)
+ = uppBesides [upp_module mod_name, uppSP,
+ uppCat (map upp_avail (sortLt lt_avail avails)),
+ uppSemi]
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities
\begin{code}
-ifaceInstances Nothing{-no iface handle-} _ = return ()
-
-ifaceInstances (Just if_hdl) inst_infos
- | null togo_insts = return ()
+ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet -- The IdSet is the needed dfuns
+ifaceInstances if_hdl inst_infos
+ | null togo_insts = return emptyIdSet
| otherwise = hPutStr if_hdl "_instances_\n" >>
- hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts)
+ hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
+ return needed_ids
where
togo_insts = filter is_togo_inst (bagToList inst_infos)
+ needed_ids = mkIdSet [dfun_id | InstInfo _ _ _ _ _ dfun_id _ _ _ <- togo_insts]
is_togo_inst (InstInfo _ _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
-------
-> IdSet -- Set of Ids that are needed by earlier interface
-- file emissions. If the Id isn't in this set, and isn't
-- exported, there's no need to emit anything
+ -> Bool -- True <=> recursive, so don't print unfolding
-> Id
-> CoreExpr -- The Id's right hand side
-> Maybe (Pretty, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids
-ifaceId get_idinfo needed_ids id rhs
- | not (wantIdSigInIface (id `elementOfIdSet` needed_ids)
- opt_OmitInterfacePragmas
- id)
+ifaceId get_idinfo needed_ids is_rec id rhs
+ | not (id `elementOfIdSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId]
+ (isExported id && not (omitIfaceSigForId id))) -- or exported and not to be omitted
= Nothing -- Well, that was easy!
-ifaceId get_idinfo needed_ids id rhs
+ifaceId get_idinfo needed_ids is_rec id rhs
= Just (ppCat [sig_pretty, prag_pretty, ppSemi], new_needed_ids)
where
- idinfo = get_idinfo id
+ idinfo = get_idinfo id
+ inline_pragma = idWantsToBeINLINEd id
+
ty_pretty = pprType PprInterface (initNmbr (nmbrType (idType id)))
sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" :: "), ty_pretty]
unfold_pretty | show_unfold = ppCat [ppStr "_U_", pprIfaceUnfolding rhs]
| otherwise = ppNil
- show_unfold = not (maybeToBool maybe_worker) && -- Unfolding is implicit
- not (bottomIsGuaranteed strict_info) && -- Ditto
- case guidance of -- Small enough to show
- UnfoldNever -> False
- other -> True
+ show_unfold = not implicit_unfolding && -- Unnecessary
+ (inline_pragma || not dodgy_unfolding) -- Dangerous
- guidance = calcUnfoldingGuidance (idWantsToBeINLINEd id)
+ implicit_unfolding = maybeToBool maybe_worker ||
+ bottomIsGuaranteed strict_info
+
+ dodgy_unfolding = is_rec || -- No recursive unfoldings please!
+ case guidance of -- Too big to show
+ UnfoldNever -> True
+ other -> False
+
+ guidance = calcUnfoldingGuidance inline_pragma
opt_InterfaceUnfoldThreshold
rhs
| otherwise = emptyIdSet
where
(_,free_vars) = addExprFVs interesting emptyIdSet rhs
- interesting bound id = not (id `elementOfIdSet` bound) &&
- not (isDataCon id) &&
- not (isWiredInName (getName id)) &&
- isLocallyDefined id
+ interesting bound id = isLocallyDefined id &&
+ not (id `elementOfIdSet` bound) &&
+ not (omitIfaceSigForId id)
\end{code}
\begin{code}
ifaceBinds :: Handle
+ -> IdSet -- These Ids are needed already
-> [Id] -- Ids used at code-gen time; they have better pragma info!
-> [CoreBinding] -- In dependency order, later depend on earlier
-> IO ()
-ifaceBinds hdl final_ids binds
+ifaceBinds hdl needed_ids final_ids binds
= hPutStr hdl (uppShow 0 (prettyToUn (ppAboves pretties))) >>
hPutStr hdl "\n"
where
Nothing -> pprTrace "ifaceBinds not found:" (ppr PprDebug id) $
getIdInfo id
- pretties = go emptyIdSet (reverse binds) -- Reverse so that later things will
+ pretties = go needed_ids (reverse binds) -- Reverse so that later things will
-- provoke earlier ones to be emitted
go needed [] = if not (isEmptyIdSet needed) then
pprTrace "ifaceBinds: free vars:"
[]
go needed (NonRec id rhs : binds)
- = case ifaceId get_idinfo needed id rhs of
+ = case ifaceId get_idinfo needed False id rhs of
Nothing -> go needed binds
Just (pretty, needed') -> pretty : go needed' binds
(needed', maybes) = mapAccumL do_one needed pairs
(final_needed, more_pretties) = go_rec needed' reduced_pairs
- do_one needed (id,rhs) = case ifaceId get_idinfo needed id rhs of
+ do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
Nothing -> (needed, Nothing)
Just (pretty, needed') -> (needed', Just pretty)
\end{code}
\begin{code}
upp_avail NotAvailable = uppNil
-upp_avail (Avail name ns) = uppBesides [upp_module mod, uppSP,
- upp_occname occ, uppSP,
- upp_export ns]
- where
- (mod,occ) = modAndOcc name
+upp_avail (Avail name ns) = uppBesides [upp_occname (getOccName name), upp_export ns]
upp_export [] = uppNil
upp_export names = uppBesides [uppStr "(",
\end{code}
\begin{code}
-voidId = pcMiscPrelId voidIdKey gHC__ SLIT("void") voidTy noIdInfo
+voidId = pc_bottoming_Id voidIdKey gHC__ SLIT("void") voidTy
\end{code}
%************************************************************************
import CStrings ( identToC )
import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset )
-import PprStyle ( codeStyle{-, PprStyle(..) ToDo:rm-} )
+import PprStyle ( codeStyle, ifaceStyle )
import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
= let
before
= if is_casm then
- if may_gc then "(_casm_GC_ ``" else "(_casm_ ``"
+ if may_gc then "_casm_GC_ ``" else "_casm_ ``"
else
- if may_gc then "(_ccall_GC_ " else "(_ccall_ "
+ if may_gc then "_ccall_GC_ " else "_ccall_ "
after
= if is_casm then ppStr "''" else ppNil
pp_tys
- = ppBesides [ppStr " { [",
- ppIntersperse pp'SP{-'-} (map (pprParendGenType sty) arg_tys),
- ppRbrack, ppSP, pprParendGenType sty res_ty, ppStr " })"]
-
+ = ppCat (map (pprParendGenType sty) (res_ty:arg_tys))
in
- ppBesides [ppStr before, ppPStr fun, after, pp_tys]
+ ppBesides [ppStr before, ppPStr fun, after, ppSP, ppLbrack, pp_tys, ppRbrack]
pprPrimOp sty other_op
- = let
- str = primOp_str other_op
- in
- (if codeStyle sty then identToC else ppPStr) str
+ | codeStyle sty -- For C just print the primop itself
+ = identToC str
+
+ | ifaceStyle sty -- For interfaces Print it qualified with GHC.
+ = ppPStr SLIT("GHC.") `ppBeside` ppPStr str
+
+ | otherwise -- Unqualified is good enough
+ = ppPStr str
+ where
+ str = primOp_str other_op
+
+
instance Outputable PrimOp where
ppr sty op = pprPrimOp sty op
| ITcbrack
| ITcparen
| ITsemi
- | ITinteger Integer -- numbers and names
| ITvarid FAST_STRING
| ITconid FAST_STRING
| ITvarsym FAST_STRING
-- Stuff for reading unfoldings
| ITarity | ITstrict | ITunfold
| ITdemand [Demand] | ITbottom
- | ITlam | ITbiglam | ITcase | ITlet | ITletrec | ITin | ITof
- | ITcoerce_in | ITcoerce_out
+ | ITlam | ITbiglam | ITcase | ITprim_case | ITlet | ITletrec | ITin | ITof
+ | ITcoerce_in | ITcoerce_out | ITatsign
+ | ITccall (Bool,Bool) -- (is_casm, may_gc)
+
| ITchar Char | ITstring FAST_STRING
+ | ITinteger Integer | ITdouble Double
+ | ITinteger_lit | ITfloat_lit | ITrational_lit | ITaddr_lit | ITlit_lit | ITstring_lit
deriving Text -- debugging
\end{code}
',' : cs -> ITcomma : lexIface cs
':' : ':' : cs -> ITdcolon : lexIface cs
';' : cs -> ITsemi : lexIface cs
- '\"' : cs -> case read input of
- ((str, rest) : _) -> ITstring (_PK_ (str::String)) : lexIface rest
- '\'' : cs -> case read input of
- ((ch, rest) : _) -> ITchar ch : lexIface rest
+ '@' : cs -> ITatsign : lexIface cs
+ '\"' : cs -> case reads input of
+ [(str, rest)] -> ITstring (_PK_ (str::String)) : lexIface rest
+ '\'' : cs -> case reads input of
+ [(ch, rest)] -> ITchar ch : lexIface rest
+
+-- ``thingy'' form for casm
+ '`' : '`' : cs -> lex_cstring "" cs
+-- Keywords
'_' : 'S' : '_' : cs -> ITstrict : lex_demand cs
'_' : cs -> lex_keyword cs
- c : cs | isDigit c -> lex_num input
- | otherwise -> lex_id input
-
- other -> error ("lexing:"++other)
+-- Numbers
+ '-' : c : cs | isDigit c -> lex_num "-" (c:cs)
+ c : cs | isDigit c -> lex_num "" (c:cs)
+
+ other -> lex_id input
where
lex_comment str
= case (span ((/=) '\n') str) of { (junk, rest) ->
lex_demand (c:cs) | isSpace c = lex_demand cs
| otherwise = case readList (c:cs) of
((demand,rest) : _) -> ITdemand demand : lexIface rest
+
-----------
- lex_num str
+ lex_num minus str
= case (span isDigit str) of { (num, rest) ->
- ITinteger (read num) : lexIface rest }
+ case rest of
+ '.' : str2 -> case (span isDigit str2) of { (num2,rest2) ->
+ ITdouble (read (minus ++ num ++ ('.':num2))) : lexIface rest2
+ }
+
+ other -> ITinteger (read (minus ++ num)) : lexIface rest
+ }
------------
lex_keyword str
is_kwd_mod_char c = isAlphanum c
-----------
+ lex_cstring so_far ('\'' : '\'' : cs) = ITstring (_PK_ (reverse (so_far::String))) : lexIface cs
+ lex_cstring so_far (c : cs) = lex_cstring (c:so_far) cs
+
+
+ -----------
lex_tuple module_dot orig_cs = go 2 orig_cs
where
go n (',':cs) = go (n+1) cs
-- NB: ':' isn't valid inside an identifier, only at the start.
-- otherwise we get confused by a::t!
+ -- Similarly ' itself is ok inside an identifier, but not at the start
is_id_char c = isAlphanum c || c `elem` "_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
lex_id cs = go [] cs
,("coerce_out_", ITcoerce_out)
,("A_", ITarity)
,("A_", ITarity)
- ,("!_", ITbottom)
-
+ ,("bot_", ITbottom)
+ ,("integer_", ITinteger_lit)
+ ,("rational_", ITrational_lit)
+ ,("addr_", ITaddr_lit)
+ ,("float_", ITfloat_lit)
+ ,("string_", ITstring_lit)
+ ,("litlit_", ITlit_lit)
+ ,("ccall_", ITccall (False, False))
+ ,("ccall_GC_", ITccall (False, True))
+ ,("casm_", ITccall (True, False))
+ ,("casm_GC_", ITccall (True, True))
]
haskellKeywordsFM = listToFM [
,("infixr", ITinfixr)
,("infix", ITinfix)
,("case", ITcase)
+ ,("case#", ITprim_case)
,("of", ITof)
,("in", ITin)
,("let", ITlet)
LAM { ITlam }
BIGLAM { ITbiglam }
CASE { ITcase }
+ PRIM_CASE { ITprim_case }
OF { ITof }
LET { ITlet }
LETREC { ITletrec }
IN { ITin }
+ ATSIGN { ITatsign }
COERCE_IN { ITcoerce_in }
COERCE_OUT { ITcoerce_out }
CHAR { ITchar $$ }
STRING { ITstring $$ }
+ DOUBLE { ITdouble $$ }
+ INTEGER_LIT { ITinteger_lit }
+ STRING_LIT { ITstring_lit }
+ FLOAT_LIT { ITfloat_lit }
+ RATIONAL_LIT { ITrational_lit }
+ ADDR_LIT { ITaddr_lit }
+ LIT_LIT { ITlit_lit }
+ CCALL { ITccall $$ }
%%
iface :: { ParsedIface }
export_items :: { [ExportItem] }
export_items : { [] }
- | export_item export_items { $1 : $2 }
+ | mod_name entities SEMI export_items { ($1,$2) : $4 }
-export_item :: { ExportItem }
-export_item : mod_name entity_occ maybe_dotdot { ($1, $2, $3) }
+entities :: { [(OccName, [OccName])] }
+entities : { [] }
+ | entity entities { $1 : $2 }
-maybe_dotdot :: { [OccName] }
-maybe_dotdot : { [] }
+entity :: { (OccName, [OccName]) }
+entity : entity_occ maybe_inside { ($1, $2) }
+
+maybe_inside :: { [OccName] }
+maybe_inside : { [] }
| OPAREN val_occs CPAREN { $2
--------------------------------------------------------------------------
}
{ TyD (TyNew $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) }
| CLASS decl_context tc_name tv_bndr csigs SEMI
{ ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) }
- | var_name DCOLON ctype id_info SEMI
+ | var_name DCOLON type id_info SEMI
{ SigD (IfaceSig $1 $3 $4 mkIfaceSrcLoc) }
decl_context :: { RdrNameContext }
| csig SEMI csigs1 { $1 : $3 }
csig :: { RdrNameSig }
-csig : var_name DCOLON ctype { ClassOpSig $1 $3 noClassOpPragmas mkIfaceSrcLoc
+csig : var_name DCOLON type { ClassOpSig $1 $3 noClassOpPragmas mkIfaceSrcLoc
----------------------------------------------------------------
}
| field COMMA fields1 { $1 : $3 }
field :: { ([RdrName], RdrNameBangType) }
-field : var_name DCOLON ctype { ([$1], Unbanged $3) }
- | var_name DCOLON BANG ctype { ([$1], Banged $4)
+field : var_name DCOLON type { ([$1], Unbanged $3) }
+ | var_name DCOLON BANG type { ([$1], Banged $4)
--------------------------------------------------------------------------
}
class :: { (RdrName, RdrNameHsType) }
class : qtc_name atype { ($1, $2) }
-ctype :: { RdrNameHsType }
-ctype : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 }
- | type { $1 }
-
type :: { RdrNameHsType }
-type : btype { $1 }
- | btype RARROW type { MonoFunTy $1 $3 }
+type : FORALL forall context DARROW tautype { mkHsForAllTy $2 $3 $5 }
+ | tautype { $1 }
+
+tautype :: { RdrNameHsType }
+tautype : btype { $1 }
+ | btype RARROW tautype { MonoFunTy $1 $3 }
-ctypes2 :: { [RdrNameHsType] {- Two or more -} }
-ctypes2 : ctype COMMA ctype { [$1,$3] }
- | ctype COMMA ctypes2 { $1 : $3 }
+types2 :: { [RdrNameHsType] {- Two or more -} }
+types2 : type COMMA type { [$1,$3] }
+ | type COMMA types2 { $1 : $3 }
btype :: { RdrNameHsType }
btype : atype { $1 }
- | qtc_name atypes1 { MonoTyApp $1 $2 }
- | tv_name atypes1 { MonoTyApp $1 $2 }
+ | qtc_name atype atypes { MonoTyApp $1 ($2:$3) }
+ | tv_name atype atypes { MonoTyApp $1 ($2:$3) }
atype :: { RdrNameHsType }
atype : qtc_name { MonoTyApp $1 [] }
| tv_name { MonoTyVar $1 }
- | OPAREN ctypes2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
+ | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
| OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 }
| OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 }
- | OPAREN ctype CPAREN { $2 }
+ | OPAREN type CPAREN { $2 }
-atypes1 :: { [RdrNameHsType] {- One or more -} }
-atypes1 : atype { [$1] }
- | atype atypes1 { $1 : $2
+atypes :: { [RdrNameHsType] {- Zero or more -} }
+atypes : { [] }
+ | atype atypes { $1 : $2
---------------------------------------------------------------------
}
var_name :: { RdrName }
var_name : var_occ { Unqual $1 }
+any_var_name :: {RdrName}
+any_var_name : var_name { $1 }
+ | qvar_name { $1 }
qdata_name :: { RdrName }
qdata_name : QCONID { varQual $1 }
| instd instdecls { $1 : $2 }
instd :: { RdrNameInstDecl }
-instd : INSTANCE ctype EQUAL var_name SEMI
+instd : INSTANCE type EQUAL var_name SEMI
{ InstDecl $2
EmptyMonoBinds {- No bindings -}
[] {- No user pragmas -}
id_info :: { [HsIdInfo RdrName] }
id_info : { [] }
- | ARITY_PART arity_info id_info { HsArity $2 : $3 }
- | STRICT_PART strict_info id_info { HsStrictness $2 : $3 }
- | UNFOLD_PART core_expr id_info { HsUnfold $2 : $3 }
+ | id_info_item id_info { $1 : $2 }
+
+id_info_item :: { HsIdInfo RdrName }
+id_info_item : ARITY_PART arity_info { HsArity $2 }
+ | STRICT_PART strict_info { HsStrictness $2 }
+ | BOTTOM { HsStrictness mkBottomStrictnessInfo }
+ | UNFOLD_PART core_expr { HsUnfold $2 }
arity_info :: { ArityInfo }
arity_info : INTEGER { exactArity (fromInteger $1) }
strict_info :: { StrictnessInfo RdrName }
-strict_info : DEMAND qvar_name { mkStrictnessInfo $1 (Just $2) }
+strict_info : DEMAND any_var_name { mkStrictnessInfo $1 (Just $2) }
| DEMAND { mkStrictnessInfo $1 Nothing }
- | BOTTOM { mkBottomStrictnessInfo }
core_expr :: { UfExpr RdrName }
-core_expr : var_name { UfVar $1 }
- | qvar_name { UfVar $1 }
+core_expr : any_var_name { UfVar $1 }
| qdata_name { UfVar $1 }
| core_lit { UfLit $1 }
+ | OPAREN core_expr CPAREN { $2 }
+
+ | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) }
| core_expr core_arg { UfApp $1 $2 }
- | LAM core_val_bndr RARROW core_expr { UfLam $2 $4 }
+ | LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 }
| BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 }
| CASE core_expr OF
OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) }
- | CASE BANG core_expr OF
- OCURLY prim_alts core_default CCURLY { UfCase $3 (UfPrimAlts $6 $7) }
+ | PRIM_CASE core_expr OF
+ OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) }
+
| LET OCURLY core_val_bndr EQUAL core_expr CCURLY
IN core_expr { UfLet (UfNonRec $3 $5) $8 }
| LETREC OCURLY rec_binds CCURLY
IN core_expr { UfLet (UfRec $3) $6 }
- | qdata_name BANG core_args { UfCon $1 $3 }
- | qvar_name BANG core_args { UfPrim (UfOtherOp $1) $3 }
| coerce atype core_expr { UfCoerce $1 $2 $3 }
+ | CCALL ccall_string
+ OBRACK atype atypes CBRACK core_args { let
+ (is_casm, may_gc) = $1
+ in
+ UfPrim (UfCCallOp $2 is_casm may_gc $5 $4)
+ $7
+ }
+
rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] }
: { [] }
| core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 }
core_default :: { UfDefault RdrName }
: { UfNoDefault }
- | core_val_bndr RARROW core_expr { UfBindDefault $1 $3 }
+ | core_val_bndr RARROW core_expr SEMI { UfBindDefault $1 $3 }
core_arg :: { UfArg RdrName }
: var_name { UfVarArg $1 }
| qvar_name { UfVarArg $1 }
| qdata_name { UfVarArg $1 }
| core_lit { UfLitArg $1 }
- | OBRACK atype CBRACK { UfTyArg $2 }
core_args :: { [UfArg RdrName] }
: { [] }
| core_arg core_args { $1 : $2 }
core_lit :: { Literal }
-core_lit : INTEGER { MachInt $1 True }
- | CHAR { MachChar $1 }
- | STRING { MachStr $1 }
+core_lit : INTEGER { MachInt $1 True }
+ | CHAR { MachChar $1 }
+ | STRING { MachStr $1 }
+ | STRING_LIT STRING { NoRepStr $2 }
+ | DOUBLE { MachDouble (toRational $1) }
+ | FLOAT_LIT DOUBLE { MachFloat (toRational $2) }
+
+ | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type")
+ -- The type checker will add the types
+ }
+
+ | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3)
+ (panic "NoRepRational type")
+ -- The type checker will add the type
+ }
+
+ | ADDR_LIT INTEGER { MachAddr $2 }
+ | LIT_LIT STRING { MachLitLit $2 (panic "ParseIface.y: ToDo: need PrimRep on LitLits in ifaces") }
core_val_bndr :: { UfBinder RdrName }
core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 }
core_tv_bndrs : { [] }
| core_tv_bndr core_tv_bndrs { $1 : $2 }
+ccall_string :: { FAST_STRING }
+ : STRING { $1 }
+ | VARID { $1 }
+ | CONID { $1 }
-- SLURP IN ALL THE NEEDED DECLARATIONS
-- Notice that the rnEnv starts empty
closeDecls rn_local_decls (availsToNameSet local_avails) []
- `thenRn` \ (rn_all_decls, imported_avails) ->
+ `thenRn` \ (rn_all_decls1, all_names1, imp_avails1) ->
-- SLURP IN ALL NEEDED INSTANCE DECLARATIONS
- -- We keep the ones that only mention things (type constructors, classes) that are
- -- already imported. Ones which don't can't possibly be useful to us.
+ -- We extract instance decls that only mention things (type constructors, classes) that are
+ -- already imported. Those that don't can't possibly be useful to us.
+ --
+ -- We do another closeDecls, so that we can slurp info for the dictionary functions
+ -- for the instance declaration. These are *not* optional because the version number on
+ -- the dfun acts as the version number for the instance declaration itself; if the
+ -- instance decl changes, so will it's dfun version number.
getImportedInstDecls `thenRn` \ imported_insts ->
let
all_big_names = mkNameSet [name | Avail name _ <- local_avails] `unionNameSets`
- mkNameSet [name | Avail name _ <- imported_avails]
+ mkNameSet [name | Avail name _ <- imp_avails1]
rn_needed_insts = [ initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl (InstD inst_decl))
| (inst_names, mod_name, inst_decl) <- imported_insts,
]
in
sequenceRn rn_needed_insts `thenRn` \ inst_decls ->
- -- Maybe we need to do another close-decls?
+ closeDecls rn_all_decls1 all_names1 imp_avails1 `thenRn` \ (rn_all_decls2, all_names2, imp_avails2) ->
-- GENERATE THE VERSION/USAGE INFO
- getImportVersions imported_avails `thenRn` \ import_versions ->
+ getImportVersions imp_avails2 `thenRn` \ import_versions ->
getNameSupplyRn `thenRn` \ name_supply ->
renamed_module = HsModule mod_name vers
trashed_exports trashed_imports trashed_fixities
- (inst_decls ++ rn_all_decls)
+ (inst_decls ++ rn_all_decls2)
loc
in
returnRn (Just (renamed_module,
closeDecls :: [RenamedHsDecl] -- Declarations got so far
-> NameSet -- Names bound by those declarations
-> [AvailInfo] -- Available stuff generated by closeDecls so far
- -> RnMG ([RenamedHsDecl], -- The closed set
- [AvailInfo]) -- Available stuff generated by closeDecls
+ -> RnMG ([RenamedHsDecl], -- input + extra decls slurped
+ NameSet, -- input + names bound by extra decls
+ [AvailInfo]) -- input + extra avails from extra decls
-- The monad includes a list of possibly-unresolved Names
-- This list is empty when closeDecls returns
case maybe_unresolved of
-- No more unresolved names; we're done
- Nothing -> returnRn (decls, import_avails)
+ Nothing -> returnRn (decls, decl_names, import_avails)
-- An "unresolved" name that we've already dealt with
Just (name,_) | name `elemNameSet` decl_names
case decl_avail of
-- Can't find the declaration; check that it was optional
- NotAvailable -> checkRn (case necessity of { Optional -> True; other -> False})
- (getDeclErr name) `thenRn_`
+ NotAvailable -> case necessity of {
+ Optional -> addWarnRn (getDeclWarn name);
+ other -> addErrRn (getDeclErr name)
+ } `thenRn_`
closeDecls decls decl_names import_avails
-- Found it
getDeclErr name sty
= ppSep [ppStr "Failed to find interface decl for", ppr sty name]
+
+getDeclWarn name sty
+ = ppSep [ppStr "Warning: failed to find (optional) interface decl for", ppr sty name]
\end{code}
%* *
%************************************************************************
-@rnTopBinds@ and @rnTopMonoBinds@ assume that the environment already
+@rnTopBinds@ assumes that the environment already
contains bindings for the binders of this particular binding.
\begin{code}
-- The parser doesn't produce other forms
-rnTopMonoBinds :: RdrNameMonoBinds
- -> [RdrNameSig]
- -> RnMS s RenamedHsBinds
-
rnTopMonoBinds EmptyMonoBinds sigs
= returnRn EmptyBinds
- extends the environment to bind them to new local names
- calls @rnMonoBinds@ to do the real work
-In contrast, @rnTopMonoBinds@ doesn't extend the environment, because that's
-already done in pass3. All it does is call @rnMonoBinds@ and discards
-the free var info.
-
\begin{code}
rnBinds :: RdrNameHsBinds
-> (RenamedHsBinds -> RnMS s (result, FreeVars))
Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs decls insts) ->
-- LOAD IT INTO Ifaces
- mapRn loadExport exports `thenRn` \ avails ->
+ mapRn loadExport exports `thenRn` \ avails_s ->
foldlRn (loadDecl load_mod) (decls_map,vers_map) decls `thenRn` \ (new_decls_map, new_vers_map) ->
foldlRn (loadInstDecl load_mod) inst_map insts `thenRn` \ new_insts_map ->
let
- export_env = (avails, fixs)
+ export_env = (concat avails_s, fixs)
-- Exclude this module from the "special-inst" modules
new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods)
returnRn new_ifaces
}
-loadExport :: ExportItem -> RnMG AvailInfo
-loadExport (mod, occ, occs)
- = new_name occ `thenRn` \ name ->
- mapRn new_name occs `thenRn` \ names ->
- returnRn (Avail name names)
+loadExport :: ExportItem -> RnMG [AvailInfo]
+loadExport (mod, entities)
+ = mapRn load_entity entities
where
new_name occ = newGlobalName mod occ
+ load_entity (occ, occs)
+ = new_name occ `thenRn` \ name ->
+ mapRn new_name occs `thenRn` \ names ->
+ returnRn (Avail name names)
+
loadVersion :: Module -> VersionMap -> (OccName,Version) -> RnMG VersionMap
loadVersion mod vers_map (occ, version)
= newGlobalName mod occ `thenRn` \ name ->
===================================================
\begin{code}
-type ExportItem = (Module, OccName, [OccName])
+type ExportItem = (Module, [(OccName, [OccName])])
type VersionInfo name = [ImportVersion name]
type ImportVersion name = (Module, Version, [LocalVersion name])
type LocalVersion name = (name, Version)
IMP_Ubiq()
-import CmdLineOpts ( opt_SourceUnchanged )
+import CmdLineOpts ( opt_SourceUnchanged, opt_NoImplicitPrelude )
import HsSyn ( HsModule(..), HsDecl(..), FixityDecl(..), Fixity, Fake, InPat, IE(..), HsTyVar,
TyDecl, ClassDecl, InstDecl, DefaultDecl, ImportDecl(..), HsBinds, IfaceSig
)
all_imports = prel_imports ++ imports
+ -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
+ -- because the former doesn't even look at Prelude.hi for instance declarations,
+ -- whereas the latter does.
prel_imports | this_mod == pRELUDE ||
- explicit_prelude_import = []
+ explicit_prelude_import ||
+ opt_NoImplicitPrelude
+ = []
| otherwise = [ImportDecl pRELUDE
False {- Not qualified -}
importsFromImportDecl :: RdrNameImportDecl
-> RnMG (RnEnv, ModuleAvails)
- -- Check for "import M ()", and then don't even look at M.
- -- This makes sense, and is actually rather useful for the Prelude.
-importsFromImportDecl (ImportDecl mod qual as_mod (Just (False,[])) loc)
- = returnRn (emptyRnEnv, emptyModuleAvails)
-
-importsFromImportDecl (ImportDecl mod qual as_mod import_spec loc)
+importsFromImportDecl (ImportDecl mod qual_only as_mod import_spec loc)
= pushSrcLocRn loc $
getInterfaceExports mod `thenRn` \ (avails, fixities) ->
filterImports mod import_spec avails `thenRn` \ filtered_avails ->
]
fixities' = [ (occ,fixity,provenance) | (occ,fixity) <- fixities ]
in
- qualifyImports mod qual as_mod (ExportEnv filtered_avails' fixities')
+ qualifyImports mod
+ True -- Want qualified names
+ (not qual_only) -- Maybe want unqualified names
+ as_mod
+ (ExportEnv filtered_avails' fixities')
where
set_name_prov name = setNameProvenance name provenance
provenance = Imported mod loc
= foldlRn getLocalDeclBinders [] decls `thenRn` \ avails ->
mapRn fixityFromFixDecl fix_decls `thenRn` \ fixities ->
qualifyImports mod
- False -- Not qualified
+ False -- Don't want qualified names
+ True -- Want unqualified names
Nothing -- No "as M" part
(ExportEnv avails fixities)
where
fully fledged @Names@.
\begin{code}
-qualifyImports :: Module -- Improrted module
- -> Bool -- True <=> qualified import
+qualifyImports :: Module -- Imported module
+ -> Bool -- True <=> want qualified import
+ -> Bool -- True <=> want unqualified import
-> Maybe Module -- Optional "as M" part
-> ExportEnv -- What's imported
-> RnMG (RnEnv, ModuleAvails)
-qualifyImports this_mod qual as_mod (ExportEnv avails fixities)
+qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities)
= -- Make the qualified-name environments, checking of course for clashes
foldlRn add_name emptyNameEnv avails `thenRn` \ name_env ->
foldlRn (add_fixity name_env) emptyFixityEnv fixities `thenRn` \ fixity_env ->
-
- -- Deal with the "qualified" part; if not qualifies then add unqualfied bindings
- if qual then
- returnRn (RnEnv name_env fixity_env, mod_avail_env)
- else
- returnRn (RnEnv (unQualify name_env) (unQualify fixity_env), mod_avail_env)
-
+ returnRn (RnEnv name_env fixity_env, mod_avail_env)
where
- mod_avail_env = unitFM this_mod avails
+ qual_mod = case as_mod of
+ Nothing -> this_mod
+ Just another_name -> another_name
+
+ mod_avail_env = unitFM qual_mod avails
add_name name_env NotAvailable = returnRn name_env
add_name name_env (Avail n ns) = foldlRn add_one name_env (n : ns)
add_one :: NameEnv -> Name -> RnMG NameEnv
- add_one env name = addOneToNameEnvRn env (Qual this_mod occ_name) name
+ add_one env name = add_to_env addOneToNameEnvRn env occ_name name
where
occ_name = nameOccName name
+ add_to_env add_fn env occ thing | qual_imp && unqual_imp = both
+ | qual_imp = qual_only
+ | unqual_imp = unqual_only
+ where
+ unqual_only = add_fn env (Unqual occ) thing
+ qual_only = add_fn env (Qual qual_mod occ) thing
+ both = unqual_only `thenRn` \ env' ->
+ add_fn env' (Qual qual_mod occ) thing
+
add_fixity name_env fixity_env (occ_name, fixity, provenance)
- | maybeToBool (lookupFM name_env qual_name) -- The name is imported
- = addOneToFixityEnvRn fixity_env qual_name (fixity,provenance)
- | otherwise -- It ain't imported
+ | maybeToBool (lookupFM name_env rdr_name) -- It's imported
+ = add_to_env addOneToFixityEnvRn fixity_env occ_name (fixity,provenance)
+ | otherwise -- It ain't imported
= returnRn fixity_env
where
- qual_name = Qual this_mod occ_name
+ -- rdr_name is a name by which the thing is guaranteed to be known,
+ -- *if it is imported at all*
+ rdr_name | qual_imp = Qual qual_mod occ_name
+ | otherwise = Unqual occ_name
\end{code}
unQualify adds an Unqual binding for every existing Qual binding.
where
rn_dfun Nothing = newDfunName src_loc `thenRn` \ n' ->
returnRn (Just n')
- rn_dfun (Just n) = lookupOptionalOccRn n `thenRn` \ n' ->
+ rn_dfun (Just n) = lookupOccRn n `thenRn` \ n' ->
+ -- The dfun is not optional, because we use its version number
+ -- to identify the version of the instance declaration
returnRn (Just n')
rn_uprag (SpecSig op ty using locn)
import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
import SimplEnv
import SimplMonad
-import SimplUtils ( mkValLamTryingEta )
import Type ( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
import TysPrim ( voidTy )
import Unique ( Unique{-instance Eq-} )
in
rhs_c new_env `thenSmpl` \ rhs' ->
let
- final_rhs
- = (if switchIsSet new_env SimplDoEtaReduction
- then mkValLamTryingEta
- else mkValLam) used_args' rhs'
+ final_rhs = mkValLam used_args' rhs'
in
returnSmpl (NonRec rhs_fun_id final_rhs,
foldl App (Var rhs_fun_id) used_arg_atoms)
import CoreLint ( lintCoreBindings )
import CoreSyn
import CoreUtils ( coreExprType )
+import SimplUtils ( etaCoreExpr )
import CoreUnfold
import Literal ( Literal(..), literalType, mkMachInt )
import ErrUtils ( ghcExit )
init_specdata = initSpecData local_tycons tycon_specs
-------------
- core_linter = if opt_DoCoreLinting
- then lintCoreBindings ppr_style
- else ( \ whodunnit spec_done binds -> binds )
+ core_linter what = if opt_DoCoreLinting
+ then (if opt_D_show_passes then
+ trace ("\n*** Core Lint result of " ++ what)
+ else id
+ )
+ lintCoreBindings ppr_style what
+ else ( \ spec_done binds -> binds )
--------------
do_core_pass info@(binds, us, spec_data, simpl_stats) to_do
6. Eliminate polymorphic case expressions. We can't generate code for them yet.
+7. Do eta reduction for lambda abstractions appearing in:
+ - the RHS of case alternatives
+ - the body of a let
+ These will otherwise turn into local bindings during Core->STG; better to
+ nuke them if possible. (In general the simplifier does eta expansion not
+ eta reduction, up to this point.)
+
+
Eliminate indirections
~~~~~~~~~~~~~~~~~~~~~~
In @elimIndirections@, we look for things at the top-level of the form...
tidyCoreExpr (Let bind body)
= tidyCoreBinding bind `thenTM` \ bind' ->
- tidyCoreExpr body `thenTM` \ body' ->
+ tidyCoreExprEta body `thenTM` \ body' ->
returnTM (Let bind' body')
tidyCoreExpr (SCC cc body)
- = tidyCoreExpr body `thenTM` \ body' ->
+ = tidyCoreExprEta body `thenTM` \ body' ->
returnTM (SCC cc body')
tidyCoreExpr (Coerce coercion ty body)
- = tidyCoreExpr body `thenTM` \ body' ->
+ = tidyCoreExprEta body `thenTM` \ body' ->
returnTM (Coerce coercion ty body')
-- Wierd case for par, seq, fork etc. See notes above.
tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
| funnyParallelOp op
= tidyCoreExpr scrut `thenTM` \ scrut' ->
- tidyCoreExpr rhs `thenTM` \ rhs' ->
+ tidyCoreExprEta rhs `thenTM` \ rhs' ->
returnTM (Case scrut' (PrimAlts [] (BindDefault binder rhs')))
-- Eliminate polymorphic case, for which we can't generate code just yet
tidy_deflt deflt `thenTM` \ deflt' ->
returnTM (PrimAlts alts' deflt')
- tidy_alg_alt (con,bndrs,rhs) = tidyCoreExpr rhs `thenTM` \ rhs' ->
+ tidy_alg_alt (con,bndrs,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
returnTM (con,bndrs,rhs')
- tidy_prim_alt (lit,rhs) = tidyCoreExpr rhs `thenTM` \ rhs' ->
+ tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
returnTM (lit,rhs')
-- We convert case x of {...; x' -> ...x'...}
tidy_deflt NoDefault = returnTM NoDefault
tidy_deflt (BindDefault bndr rhs)
- = extend_env (tidyCoreExpr rhs) `thenTM` \ rhs' ->
+ = extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
returnTM (BindDefault bndr rhs')
where
extend_env = case scrut of
Var v -> extendEnvTM bndr v
other -> \x -> x
+
+tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
+ returnTM (etaCoreExpr e')
\end{code}
Arguments
| otherwise = expr_cc
where
expr_cc = coreExprCc rhs
+\end{code}
+
-{- We need to be pretty careful when extending
- the environment with RHS info in recursive groups.
+
+Recursive bindings
+~~~~~~~~~~~~~~~~~~
+We need to be pretty careful when extending
+the environment with RHS info in recursive groups.
Here's a nasty example:
(a) we inline un-simplified RHSs, and then simplify
them in a clone-only environment.
(b) we inline only variables and values
-This means taht
+This means that
r = f x ==> r = f x
x = 1:y
which is OK if not clever.
--}
+\begin{code}
extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
(out_id, ((_,occ_info), old_rhs))
= SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
floatExposesHNF,
- mkTyLamTryingEta, mkValLamTryingEta,
+ etaCoreExpr,
etaExpandCount,
IMPORT_DELOOPER(SmplLoop) -- paranoia checking
import BinderInfo
-import CmdLineOpts ( SimplifierSwitch(..) )
+import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) )
import CoreSyn
import CoreUnfold ( SimpleUnfolding, mkFormSummary, FormSummary(..) )
import Id ( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys,
import PrimOp ( primOpIsCheap )
import SimplEnv
import SimplMonad
-import Type ( eqTy, isPrimType, maybeAppDataTyConExpandingDicts, getTyVar_maybe )
+import Type ( tyVarsOfType, isPrimType, maybeAppDataTyConExpandingDicts )
import TysWiredIn ( realWorldStateTy )
-import TyVar ( GenTyVar{-instance Eq-} )
+import TyVar ( elementOfTyVarSet,
+ GenTyVar{-instance Eq-} )
import Util ( isIn, panic )
\end{code}
try_deflt (BindDefault _ rhs) = try rhs
\end{code}
+Eta reduction
+~~~~~~~~~~~~~
+@etaCoreExpr@ trys an eta reduction at the top level of a Core Expr.
-Eta reduction on ordinary lambdas
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have a go at doing
+e.g. \ x y -> f x y ===> f
- \ x y -> f x y ===> f
+It is used
+ 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 it gets rid of a whole lambda, not part.
The idea is that lambdas are often quite helpful: they indicate
gives rise to a recursive function for the list comprehension, and
f turns out to be just a single call to this recursive function.
-\begin{code}
-mkValLamTryingEta :: [Id] -- Args to the lambda
- -> CoreExpr -- Lambda body
- -> CoreExpr
+Doing eta on type lambdas is useful too:
-mkValLamTryingEta [] body = body
+ /\a -> <expr> a ===> <expr>
-mkValLamTryingEta orig_ids body
- = reduce_it (reverse orig_ids) body
- where
- bale_out = mkValLam orig_ids body
+where <expr> doesn't mention a.
+This is sometimes quite useful, because we can get the sequence:
+
+ f ab d = let d1 = ...d... in
+ letrec f' b x = ...d...(f' b)... in
+ f' b
+specialise ==>
+
+ f.Int b = letrec f' b x = ...dInt...(f' b)... in
+ f' b
+
+float ==>
+
+ f' b x = ...dInt...(f' b)...
+ f.Int b = f' b
- reduce_it [] residual
- | residual_ok residual = residual
- | otherwise = bale_out
+Now we really want to simplify to
- reduce_it (id:ids) (App fun (VarArg arg))
- | id == arg
- && not (idType id `eqTy` realWorldStateTy)
- -- *never* eta-reduce away a PrimIO state token! (WDP 94/11)
- = reduce_it ids fun
+ f.Int = f'
- reduce_it ids other = bale_out
+and then replace all the f's with f.Ints.
- is_elem = isIn "mkValLamTryingEta"
+N.B. We are careful not to partially eta-reduce a sequence of type
+applications since this breaks the specialiser:
+
+ /\ a -> f Char# a =NO=> f Char#
+
+\begin{code}
+etaCoreExpr :: CoreExpr -> CoreExpr
+
+
+etaCoreExpr expr@(Lam bndr body)
+ | opt_DoEtaReduction
+ = case etaCoreExpr body of
+ App fun arg | eta_match bndr arg &&
+ residual_ok fun
+ -> fun -- Eta
+ other -> expr -- Can't eliminate it, so do nothing at all
+ where
+ eta_match (ValBinder v) (VarArg v') = v == v'
+ eta_match (TyBinder tv) (TyArg ty) = tv `elementOfTyVarSet` tyVarsOfType ty
+ eta_match bndr arg = False
- -----------
residual_ok :: CoreExpr -> Bool -- Checks for type application
-- and function not one of the
-- bound vars
- residual_ok (Var v) = not (v `is_elem` orig_ids)
- -- Fun mustn't be one of the bound ids
+ residual_ok (Var v)
+ = not (eta_match bndr (VarArg v))
residual_ok (App fun arg)
- | notValArg arg = residual_ok fun
- residual_ok other = False
+ | eta_match bndr arg = False
+ | otherwise = residual_ok fun
+ residual_ok (Coerce coercion ty body)
+ | eta_match bndr (TyArg ty) = False
+ | otherwise = residual_ok body
+
+ residual_ok other = False -- Safe answer
+ -- This last clause may seem conservative, but consider:
+ -- primops, constructors, and literals, are impossible here
+ -- let and case are unlikely (the argument would have been floated inside)
+ -- SCCs we probably want to be conservative about (not sure, but it's safe to be)
+
+etaCoreExpr expr = expr -- The common case
\end{code}
+
Eta expansion
~~~~~~~~~~~~~
\end{code}
-Eta reduction on type lambdas
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have a go at doing
-
- /\a -> <expr> a ===> <expr>
-
-where <expr> doesn't mention a.
-This is sometimes quite useful, because we can get the sequence:
-
- f ab d = let d1 = ...d... in
- letrec f' b x = ...d...(f' b)... in
- f' b
-specialise ==>
-
- f.Int b = letrec f' b x = ...dInt...(f' b)... in
- f' b
-
-float ==>
-
- f' b x = ...dInt...(f' b)...
- f.Int b = f' b
-
-Now we really want to simplify to
-
- f.Int = f'
-
-and then replace all the f's with f.Ints.
-
-N.B. We are careful not to partially eta-reduce a sequence of type
-applications since this breaks the specialiser:
-
- /\ a -> f Char# a =NO=> f Char#
-
-\begin{code}
-mkTyLamTryingEta :: [TyVar] -> CoreExpr -> CoreExpr
-
-mkTyLamTryingEta tyvars tylam_body
- = if
- tyvars == tyvar_args && -- Same args in same order
- check_fun fun -- Function left is ok
- then
- -- Eta reduction worked
- fun
- else
- -- The vastly common case
- mkTyLam tyvars tylam_body
- where
- (tyvar_args, fun) = strip_tyvar_args [] tylam_body
-
- strip_tyvar_args args_so_far tyapp@(App fun (TyArg ty))
- = case getTyVar_maybe ty of
- Just tyvar_arg -> strip_tyvar_args (tyvar_arg:args_so_far) fun
- Nothing -> (args_so_far, tyapp)
-
- strip_tyvar_args args_so_far (App _ (UsageArg _))
- = panic "SimplUtils.mkTyLamTryingEta: strip_tyvar_args UsageArg"
-
- strip_tyvar_args args_so_far fun
- = (args_so_far, fun)
-
- check_fun (Var f) = True -- Claim: tyvars not mentioned by type of f
- check_fun other = False
-\end{code}
Let to case
~~~~~~~~~~~
-- wrappers, even thouth the former have an unfold-always guidance.
costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env)
= tick UnfoldingDone `thenSmpl_`
+#ifdef DEBUG
+ simplCount `thenSmpl` \ n ->
+ (if n > 3000 then
+ pprTrace "Ticks > 3000 and unfolding" (ppr PprDebug var)
+ else
+ id
+ )
+#endif
simplExpr unfold_env unf_template args
| maybeToBool maybe_specialisation
---------- Unfolding stuff
maybe_unfolding_info
= case (lookupOutIdEnv env var, unfolding_from_id) of
+
(Just (_, occ_info, OutUnfolding enc_cc unf), _)
-> Just (occ_info, setEnclosingCC env enc_cc, unf)
+
(Just (_, occ_info, InUnfolding env_unf unf), _)
- -> Just (occ_info, combineSimplEnv env env_unf, unf)
+ -> Just (occ_info, env_unf, unf)
+-- This combineSimplEnv is WRONG. InUnfoldings are used for
+-- recursive decls, and we're relying on using the old unfold enf
+-- to avoid getting outselves in a loop!
+-- -> Just (occ_info, combineSimplEnv env env_unf, unf)
+
(_, CoreUnfolding unf)
-> Just (noBinderInfo, env, unf)
simplExpr (extendTyEnv env tyvar ty) body args
simplExpr env tylam@(Lam (TyBinder tyvar) body) []
- = do_tylambdas env [] tylam
- where
- do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
- = -- Clone the type variable
- cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
- let
- new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
- in
- do_tylambdas new_env (tyvar':tyvars') body
-
- do_tylambdas env tyvars' body
- = simplExpr env body [] `thenSmpl` \ body' ->
- returnSmpl (
- (if switchIsSet env SimplDoEtaReduction
- then mkTyLamTryingEta
- else mkTyLam) (reverse tyvars') body'
- )
+ = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
+ let
+ new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
+ in
+ simplExpr new_env body [] `thenSmpl` \ body' ->
+ returnSmpl (Lam (TyBinder tyvar') body')
#ifdef DEBUG
simplExpr env (Lam (TyBinder _) _) (_ : _)
-> SmplM (OutExpr, ArityInfo)
simplRhsExpr env binder@(id,occ_info) rhs
- | dont_eta_expand rhs
- = simplExpr rhs_env rhs [] `thenSmpl` \ rhs' ->
- returnSmpl (rhs', unknownArity)
-
- | otherwise -- Have a go at eta expansion
= -- Deal with the big lambda part
ASSERT( null uvars ) -- For now
simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ (lambda', arity) ->
-- Put it back together
- returnSmpl (
- (if switchIsSet env SimplDoEtaReduction
- then mkTyLamTryingEta
- else mkTyLam) tyvars' lambda',
- arity
- )
+ returnSmpl (mkTyLam tyvars' lambda', arity)
where
rhs_env | -- not (switchIsSet env IgnoreINLINEPragma) &&
-- We havn't solved this problem yet!
(uvars, tyvars, body) = collectUsageAndTyBinders rhs
-
- -- dont_eta_expand prevents eta expansion in silly situations.
- -- For example, consider the defn
- -- x = y
- -- It would be silly to eta expand the "y", because it would just
- -- get eta-reduced back to y. Furthermore, if this was a top level defn,
- -- and x was exported, then the defn won't be eliminated, so this
- -- silly expand/reduce cycle will happen every time, which makes the
- -- simplifier loop!.
- -- The solution is to not even try eta expansion unless the rhs looks
- -- non-trivial.
- dont_eta_expand (Lit _) = True
- dont_eta_expand (Var _) = True
- dont_eta_expand (Con _ _) = True
- dont_eta_expand (App f a)
- | notValArg a = dont_eta_expand f
- dont_eta_expand (Lam x b)
- | notValBinder x = dont_eta_expand b
- dont_eta_expand _ = False
\end{code}
new_env = extendIdEnvWithClones env binders binders'
in
simplExpr new_env body [] `thenSmpl` \ body' ->
- returnSmpl (
- (if switchIsSet new_env SimplDoEtaReduction
- then mkValLamTryingEta
- else mkValLam) binders' body',
- atLeastArity no_of_binders
- )
+ returnSmpl (mkValLam binders' body', atLeastArity no_of_binders)
| otherwise -- Eta expansion possible
= tick EtaExpansion `thenSmpl_`
newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
returnSmpl (
- (if switchIsSet new_env SimplDoEtaReduction
- then mkValLamTryingEta
- else mkValLam) (binders' ++ extra_binders') body',
+ mkValLam (binders' ++ extra_binders') body',
atLeastArity (no_of_binders + no_of_extra_binders)
)
(Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
returnSmpl (env2, binds1 ++ binds2)
- where
- is_atomic (Var v) = True
- is_atomic (Lit l) = not (isNoRepLit l)
- is_atomic other = False
- -- Atomic right-hand sides.
- -- We used to have a "tick AtomicRhs" in here, but it causes more trouble
- -- than it's worth. For a top-level binding a = b, where a is exported,
- -- we can't drop the binding, so we get repeated AtomicRhs ticks
-completeNonRec env binder new_id rhs@(Var v)
- = returnSmpl (extendIdEnvWithAtom env binder (VarArg v), [NonRec new_id rhs])
-
-completeNonRec env binder new_id rhs@(Lit lit)
- | not (isNoRepLit lit)
- = returnSmpl (extendIdEnvWithAtom env binder (LitArg lit), [NonRec new_id rhs])
-
-- Right hand sides that are constructors
-- let v = C args
-- in
maybe_existing_con = lookForConstructor env con con_args
Just it = maybe_existing_con
+
-- Default case
-completeNonRec env binder@(id,occ_info) new_id rhs
- = returnSmpl (new_env, [NonRec new_id rhs])
+ -- Check for atomic right-hand sides.
+ -- We used to have a "tick AtomicRhs" in here, but it causes more trouble
+ -- than it's worth. For a top-level binding a = b, where a is exported,
+ -- we can't drop the binding, so we get repeated AtomicRhs ticks
+completeNonRec env binder@(id,occ_info) new_id new_rhs
+ = returnSmpl (new_env , [NonRec new_id new_rhs])
where
- env1 = extendIdEnvWithClone env binder new_id
- new_env = extendEnvGivenBinding env1 occ_info new_id rhs
+ new_env | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
+ = extendIdEnvWithAtom env binder the_arg
+
+ | otherwise -- Non-atomic
+ = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
+ occ_info new_id new_rhs -- Don't eta if it doesn't eliminate the binding
+
+ eta'd_rhs = etaCoreExpr new_rhs
+ the_arg = case eta'd_rhs of
+ Var v -> VarArg v
+ Lit l -> LitArg l
\end{code}
%************************************************************************
var `withArity` UnknownArity = var
var `withArity` arity = var `addIdArity` arity
+
+is_atomic (Var v) = True
+is_atomic (Lit l) = not (isNoRepLit l)
+is_atomic other = False
\end{code}
liftExpr expr@(StgPrim op args lvs) = returnLM (expr, emptyLiftInfo)
liftExpr expr@(StgApp (StgLitArg lit) args lvs) = returnLM (expr, emptyLiftInfo)
+liftExpr expr@(StgApp (StgConArg con) args lvs) = returnLM (expr, emptyLiftInfo)
liftExpr expr@(StgApp (StgVarArg v) args lvs)
= lookUp v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to
-- poke these bindings too early!
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[SatStgRhs]{Saturates RHSs when they are partial applications}
-
-96/03: This is actually an essential module, as it sets arity info
-for the code generator.
-
-\begin{display}
-Subject: arg satis check
-Date: Wed, 29 Apr 92 13:33:58 +0100
-From: Simon L Peyton Jones <simonpj>
-
-Andre
-
-Another transformation to consider. We'd like to avoid
-argument-satisfaction checks wherever possible. So, whenever we have an
-STG binding application
-
- f = vs \ xs -> g e1 ... en
-
-where xs has one or more elements
-and
-where g is a known function with arity m+n,
-
-then: change it to
-
- f = vs \ xs++{x1...xm} -> g e1 ... en x1 .. xm
-
-Now g has enough args. One arg-satisfaction check disappears;
-the one for the closure incorporates the one for g.
-
-You might like to consider variants, applying the transformation more
-widely. I concluded that this was the only instance which made
-sense, but I could be wrong.
-
-Simon
-\end{display}
-
-The algorithm proceeds as follows:
-\begin{enumerate}
-\item
-Gather the arity information of the functions defined in this module
-(as @getIdArity@ only knows about the arity of @ImportedIds@).
-
-\item
-for every definition of the form
-\begin{verbatim}
- v = /\ts -> \vs -> f args
-\end{verbatim}
-we try to match the arity of \tr{f} with the number of arguments.
-If they do not match we insert extra lambdas to make that application
-saturated.
-\end{enumerate}
-
-This is done for local definitions as well.
-
-\begin{code}
-#include "HsVersions.h"
-
-module SatStgRhs ( satStgRhs ) where
-
-IMP_Ubiq(){-uitous-}
-
-import StgSyn
-
-import CostCentre ( isCafCC, subsumedCosts, useCurrentCostCentre )
-import Id ( idType, getIdArity, addIdArity, mkSysLocal,
- nullIdEnv, addOneToIdEnv, growIdEnvList,
- lookupIdEnv, SYN_IE(IdEnv)
- )
-import SrcLoc ( noSrcLoc )
-import Type ( splitSigmaTy, splitForAllTy, splitFunTyExpandingDicts )
-import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
-import Util ( panic, assertPanic )
-
-type Count = Int
-
-type ExprArityInfo = Maybe Int -- Just n => This expression has a guaranteed
- -- arity of n
- -- Nothing => Don't know how many args it needs
-
-type Id_w_Arity = Id -- An Id with correct arity info pinned on it
-type SatEnv = IdEnv Id_w_Arity -- Binds only local, let(rec)-bound things
-\end{code}
-
-This pass
-\begin{itemize}
-\item adds extra args where necessary;
-\item pins the correct arity on everything.
-\end{itemize}
-
-%************************************************************************
-%* *
-\subsection{Top-level list of bindings (a ``program'')}
-%* *
-%************************************************************************
-
-\begin{code}
-satStgRhs :: [StgBinding] -> UniqSM [StgBinding]
-satStgRhs = panic "satStgRhs"
-
-{- NUKED FOR NOW SLPJ Dec 96
-
-
-satStgRhs p = satProgram nullIdEnv p
-
-satProgram :: SatEnv -> [StgBinding] -> UniqSM [StgBinding]
-satProgram env [] = returnUs []
-
-satProgram env (bind:binds)
- = satBinding True{-toplevel-} env bind `thenUs` \ (env2, bind2) ->
- satProgram env2 binds `thenUs` \ binds2 ->
- returnUs (bind2 : binds2)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Bindings}
-%* *
-%************************************************************************
-
-\begin{code}
-satBinding :: Bool -- True <=> top-level
- -> SatEnv
- -> StgBinding
- -> UniqSM (SatEnv, StgBinding)
-
-satBinding top env (StgNonRec b rhs)
- = satRhs top env (b, rhs) `thenUs` \ (b2, rhs2) ->
- let
- env2 = addOneToIdEnv env b b2
- in
- returnUs (env2, StgNonRec b2 rhs2)
-
-satBinding top env (StgRec pairs)
- = -- Do it once to get the arities right...
- mapUs (satRhs top env) pairs `thenUs` \ pairs2 ->
- let
- env2 = growIdEnvList env (map fst pairs `zip` map fst pairs2)
- in
- -- Do it again to *use* those arities:
- mapUs (satRhs top env2) pairs `thenUs` \ pairs3 ->
-
- returnUs (env2, StgRec pairs3)
-
-satRhs :: Bool -> SatEnv -> (Id, StgRhs) -> UniqSM (Id_w_Arity, StgRhs)
-
-satRhs top env (b, StgRhsCon cc con args) -- Nothing much to do here
- = let
- b2 = b `addIdArity` 0 -- bound to a saturated constructor; hence zero.
- in
- returnUs (b2, StgRhsCon cc con (lookupArgs env args))
-
-satRhs top env (b, StgRhsClosure cc bi fv u args body)
- = satExpr env body `thenUs` \ (arity_info, body2) ->
- let
- num_args = length args
- in
- (case arity_info of
- Nothing ->
- returnUs (num_args, StgRhsClosure cc bi fv u args body2)
-
- Just needed_args ->
- ASSERT(needed_args >= 1)
-
- let -- the arity we're aiming for is: what we already have ("args")
- -- plus the ones requested in "arity_info"
- new_arity = num_args + needed_args
-
- -- get type info for this function:
- (_, rho_ty) = splitForAllTy (idType b)
- (all_arg_tys, _) = splitFunTyExpandingDicts rho_ty
-
- -- now, we already have "args"; we drop that many types
- args_we_dont_have_tys = drop num_args all_arg_tys
-
- -- finally, we take some of those (up to maybe all of them),
- -- depending on how many "needed_args"
- args_to_add_tys = take needed_args args_we_dont_have_tys
- in
- -- make up names for them
- mapUs newName args_to_add_tys `thenUs` \ nns ->
-
- -- and do the business
- let
- body3 = saturate body2 (map StgVarArg nns)
-
- new_cc -- if we're adding args, we'd better not
- -- keep calling something a CAF! (what about DICTs? ToDo: WDP 95/02)
- = if not (isCafCC cc)
- then cc -- unchanged
- else if top then subsumedCosts else useCurrentCostCentre
- in
- returnUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3)
- )
- `thenUs` \ (arity, rhs2) ->
- let
- b2 = b `addIdArity` arity
- in
- returnUs (b2, rhs2)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-satExpr :: SatEnv -> StgExpr -> UniqSM (ExprArityInfo, StgExpr)
-
-satExpr env app@(StgApp (StgLitArg lit) [] lvs) = returnUs (Nothing, app)
-
-satExpr env app@(StgApp (StgVarArg f) as lvs)
- = returnUs (arity_to_return, StgApp (StgVarArg f2) as2 lvs)
- where
- as2 = lookupArgs env as
- f2 = lookupVar env f
- arity_to_return = case arityMaybe (getIdArity f2) of
- Nothing -> Nothing
-
- Just f_arity -> if remaining_arity > 0
- then Just remaining_arity
- else Nothing
- where
- remaining_arity = f_arity - length as
-
-satExpr env app@(StgCon con as lvs)
- = returnUs (Nothing, StgCon con (lookupArgs env as) lvs)
-
-satExpr env app@(StgPrim op as lvs)
- = returnUs (Nothing, StgPrim op (lookupArgs env as) lvs)
-
-satExpr env (StgSCC ty l e)
- = satExpr env e `thenUs` \ (_, e2) ->
- returnUs (Nothing, StgSCC ty l e2)
-
-{- OMITTED: Let-no-escapery should come *after* saturation
-
-satExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
- = satBinding binds `thenUs` \ (binds2, c) ->
- satExpr body `thenUs` \ (_, body2, c2) ->
- returnUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2)
--}
-
-satExpr env (StgLet binds body)
- = satBinding False{-not top-level-} env binds `thenUs` \ (env2, binds2) ->
- satExpr env2 body `thenUs` \ (_, body2) ->
- returnUs (Nothing, StgLet binds2 body2)
-
-satExpr env (StgCase expr lve lva uniq alts)
- = satExpr env expr `thenUs` \ (_, expr2) ->
- sat_alts alts `thenUs` \ alts2 ->
- returnUs (Nothing, StgCase expr2 lve lva uniq alts2)
- where
- sat_alts (StgAlgAlts ty alts def)
- = mapUs sat_alg_alt alts `thenUs` \ alts2 ->
- sat_deflt def `thenUs` \ def2 ->
- returnUs (StgAlgAlts ty alts2 def2)
- where
- sat_alg_alt (id, bs, use_mask, e)
- = satExpr env e `thenUs` \ (_, e2) ->
- returnUs (id, bs, use_mask, e2)
-
- sat_alts (StgPrimAlts ty alts def)
- = mapUs sat_prim_alt alts `thenUs` \ alts2 ->
- sat_deflt def `thenUs` \ def2 ->
- returnUs (StgPrimAlts ty alts2 def2)
- where
- sat_prim_alt (l, e)
- = satExpr env e `thenUs` \ (_, e2) ->
- returnUs (l, e2)
-
- sat_deflt StgNoDefault
- = returnUs StgNoDefault
-
- sat_deflt (StgBindDefault b u expr)
- = satExpr env expr `thenUs` \ (_,expr2) ->
- returnUs (StgBindDefault b u expr2)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Utility functions}
-%* *
-%************************************************************************
-
-\begin{code}
-saturate :: StgExpr -> [StgArg] -> StgExpr
-
-saturate (StgApp f as lvs) ids = StgApp f (as ++ ids) lvs
-saturate other _ = panic "SatStgRhs: saturate"
-\end{code}
-
-\begin{code}
-lookupArgs :: SatEnv -> [StgArg] -> [StgArg]
-lookupArgs env args = map doo args
- where
- doo (StgVarArg v) = StgVarArg (lookupVar env v)
- doo a@(StgLitArg lit) = a
-
-lookupVar :: SatEnv -> Id -> Id
-lookupVar env v = case lookupIdEnv env v of
- Nothing -> v
- Just v2 -> v2
-
-newName :: Type -> UniqSM Id
-newName ut
- = getUnique `thenUs` \ uniq ->
- returnUs (mkSysLocal SLIT("sat") uniq ut noSrcLoc)
-
--}
-\end{code}
IMPORT_1_3(IO(hPutStr,stderr))
import StgSyn
-import StgUtils
import LambdaLift ( liftProgram )
import Name ( isLocallyDefined )
import SCCfinal ( stgMassageForProfiling )
-import SatStgRhs ( satStgRhs )
import StgLint ( lintStgBindings )
import StgStats ( showStgStats )
import StgVarInfo ( setStgVarInfo )
= mapLne var_atom atoms `thenLne` \ fvs_lists ->
returnLne (unionFVInfos fvs_lists)
where
- var_atom a@(StgLitArg _) = returnLne emptyFVInfo
+ var_atom a@(StgLitArg _) = returnLne emptyFVInfo
+ var_atom a@(StgConArg _) = returnLne emptyFVInfo
var_atom a@(StgVarArg v)
= lookupVarEnv v `thenLne` \ how_bound ->
returnLne (singletonFVInfo v how_bound stgArgOcc)
varsExpr (StgApp lit@(StgLitArg _) args _)
= returnLne (StgApp lit [] emptyIdSet, emptyFVInfo, emptyIdSet)
+varsExpr (StgApp lit@(StgConArg _) args _)
+ = panic "varsExpr StgConArg" -- Only occur in argument positions
+
varsExpr (StgApp fun@(StgVarArg f) args _) = varsApp Nothing f args
varsExpr (StgCon con args _)
= coreRhsToStg env rhs `thenUs` \ stg_rhs ->
let
-- Binds to return if RHS is trivial
- triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs] -- Retain it
- | otherwise = [] -- Discard it
+ binder_w_arity = binder `addIdArity` (rhsArity stg_rhs)
+ triv_binds | externallyVisibleId binder = [StgNonRec binder_w_arity stg_rhs] -- Retain it
+ | otherwise = [] -- Discard it
in
case stg_rhs of
StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
-- Trivial RHS, so augment envt, and ditch the binding
returnUs (triv_binds, new_env)
where
- new_env = addOneToIdEnv env binder (StgVarArg con_id)
+ new_env = addOneToIdEnv env binder (StgConArg con_id)
other -> -- Non-trivial RHS, so don't augment envt
returnUs ([StgNonRec binder_w_arity stg_rhs], new_env)
where
- binder_w_arity = binder `addIdArity` (rhsArity stg_rhs)
new_env = addOneToIdEnv env binder (StgVarArg binder_w_arity)
-- new_env propagates the arity
= returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs)
coreExprToStg env (Var var)
- = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs)
+ = returnUs (mk_app (stgLookup env var) [])
coreExprToStg env (Con con args)
= let
case (fun, args) of
(Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
-- there are no arguments.
- returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs)
+ returnUs (mk_app (stgLookup env fun_id) stg_args)
(non_var_fun, []) -> -- No value args, so recurse into the function
coreExprToStg env non_var_fun
-> StgExpr
mkStgLets binds body = foldr StgLet body binds
+
+-- mk_app spots an StgCon in a function position,
+-- and turns it into an StgCon. See notes with
+-- getArgAmode in CgBindery.
+mk_app (StgConArg con) args = StgCon con args bOGUS_LVs
+mk_app other_fun args = StgApp other_fun args bOGUS_LVs
\end{code}
lintStgArg :: StgArg -> LintM (Maybe Type)
lintStgArg (StgLitArg lit) = returnL (Just (literalType lit))
+lintStgArg (StgConArg con) = returnL (Just (idType con))
lintStgArg a@(StgVarArg v)
= checkInScope v `thenL_`
returnL (Just (idType v))
IMP_Ubiq(){-uitous-}
import CostCentre ( showCostCentre )
-import Id ( idPrimRep, GenId{-instance NamedThing-} )
+import Id ( idPrimRep, SYN_IE(DataCon), GenId{-instance NamedThing-} )
import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
import Name ( pprNonSym )
import Outputable ( ifPprDebug, interppSP, interpp'SP,
data GenStgArg occ
= StgVarArg occ
| StgLitArg Literal
+ | StgConArg DataCon -- A nullary data constructor
\end{code}
\begin{code}
getArgPrimRep (StgVarArg local) = idPrimRep local
+getArgPrimRep (StgConArg con) = idPrimRep con
getArgPrimRep (StgLitArg lit) = literalPrimRep lit
isLitLitArg (StgLitArg x) = isLitLitLit x
pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
pprStgArg sty (StgVarArg var) = ppr sty var
+pprStgArg sty (StgConArg con) = ppr sty con
pprStgArg sty (StgLitArg lit) = ppr sty lit
\end{code}
+++ /dev/null
-x%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
-%
-\section[StgUtils]{Utility functions for @STG@ programs}
-
-\begin{code}
-#include "HsVersions.h"
-
-module StgUtils
- -- ( mapStgBindeesRhs ) Dead code SLPJ Nov 96
- where
-{- DEAD CODE SLPJ Nov 96
-
-IMP_Ubiq(){-uitous-}
-
-import Id ( GenId{-instanced NamedThing-} )
-import StgSyn
-import UniqSet
-\end{code}
-
-This utility function simply applies the given function to every
-bindee in the program.
-
-\begin{code}
-
-mapStgBindeesBind :: (Id -> Id) -> StgBinding -> StgBinding
-
-mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs)
-mapStgBindeesBind fn (StgRec pairs) = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
-
-------------------
-mapStgBindeesRhs :: (Id -> Id) -> StgRhs -> StgRhs
-
-mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr)
- = StgRhsClosure
- cc bi
- (map fn fvs)
- u
- (map fn args)
- (mapStgBindeesExpr fn expr)
-
-mapStgBindeesRhs fn (StgRhsCon cc con atoms)
- = StgRhsCon cc con (map (mapStgBindeesArg fn) atoms)
-
-------------------
-mapStgBindeesExpr :: (Id -> Id) -> StgExpr -> StgExpr
-
-mapStgBindeesExpr fn (StgApp f args lvs)
- = StgApp (mapStgBindeesArg fn f)
- (map (mapStgBindeesArg fn) args)
- (mapUniqSet fn lvs)
-
-mapStgBindeesExpr fn (StgCon con atoms lvs)
- = StgCon con (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs)
-
-mapStgBindeesExpr fn (StgPrim op atoms lvs)
- = StgPrim op (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs)
-
-mapStgBindeesExpr fn (StgLet bind expr)
- = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr)
-
-mapStgBindeesExpr fn (StgLetNoEscape lvs rhss_lvs bind body)
- = StgLetNoEscape (mapUniqSet fn lvs) (mapUniqSet fn rhss_lvs)
- (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn body)
-
-mapStgBindeesExpr fn (StgSCC ty label expr)
- = StgSCC ty label (mapStgBindeesExpr fn expr)
-
-mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts)
- = StgCase (mapStgBindeesExpr fn expr)
- (mapUniqSet fn lvs1)
- (mapUniqSet fn lvs2)
- uniq
- (mapStgBindeesAlts alts)
- where
- mapStgBindeesAlts (StgAlgAlts ty alts deflt)
- = StgAlgAlts ty (map mapStgBindeesBoxed_alt alts) (mapStgBindeesDeflt deflt)
- where
- mapStgBindeesBoxed_alt (c,ps,use_mask,expr) = (c,ps,use_mask,mapStgBindeesExpr fn expr)
-
- mapStgBindeesAlts (StgPrimAlts ty alts deflt)
- = StgPrimAlts ty (map mapStgBindeesunboxed_alt alts) (mapStgBindeesDeflt deflt)
- where
- mapStgBindeesunboxed_alt (l,expr) = (l,mapStgBindeesExpr fn expr)
-
- mapStgBindeesDeflt StgNoDefault = StgNoDefault
- mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr)
-
-------------------
-mapStgBindeesArg :: (Id -> Id) -> StgArg -> StgArg
-
-mapStgBindeesArg fn a@(StgLitArg _) = a
-mapStgBindeesArg fn a@(StgVarArg id) = StgVarArg (fn id)
-
--}
-\end{code}
else
AbsBot
where
- is_fun (AbsFun _ _ _) = True
- is_fun (AbsApproxFun _) = True -- Not used, but the glb works ok
- is_fun other = False
+ is_fun (AbsFun _ _ _) = True
+ is_fun (AbsApproxFun _ _) = True -- Not used, but the glb works ok
+ is_fun other = False
-- The non-functional cases are quite straightforward
\begin{code}
isBot :: AbsVal -> Bool
-isBot AbsBot = True
-isBot (AbsFun args body env) = isBot (absEval StrAnal body env)
+isBot AbsBot = True
+isBot (AbsFun arg body env) = isBot (absEval StrAnal body env)
-- Don't bother to extend the envt because
-- unbound variables default to AbsTop anyway
-isBot other = False
+isBot other = False
\end{code}
Used only in absence analysis:
anyBot AbsBot = True -- poisoned!
anyBot AbsTop = False
anyBot (AbsProd vals) = any anyBot vals
-anyBot (AbsFun args body env) = anyBot (absEval AbsAnal body env)
-anyBot (AbsApproxFun demands) = False
+anyBot (AbsFun arg body env) = anyBot (absEval AbsAnal body env)
+anyBot (AbsApproxFun _ _) = False
-- AbsApproxFun can only arise in absence analysis from the Demand
-- info of an imported value; whatever it is we're looking for is
\begin{code}
widen :: AnalysisKind -> AbsVal -> AbsVal
-widen StrAnal (AbsFun args body env)
- | isBot (absEval StrAnal body env) = AbsBot
- | otherwise
- = ASSERT (not (null args))
- AbsApproxFun (map (findDemandStrOnly env body) args)
+widen StrAnal (AbsFun arg body env)
+ = AbsApproxFun (findDemandStrOnly env body arg)
+ (widen StrAnal abs_body)
+ where
+ abs_body = absEval StrAnal body env
+
+{- OLD comment...
+ This stuff is now instead handled neatly by the fact that AbsApproxFun
+ contains an AbsVal inside it. SLPJ Jan 97
+ | isBot abs_body = AbsBot
-- It's worth checking for a function which is unconditionally
-- bottom. Consider
--
-- alternative here would be to bind g to its exact abstract
-- value, but that entails lots of potential re-computation, at
-- every application of g.)
+-}
widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
widen StrAnal other_val = other_val
-widen AbsAnal (AbsFun args body env)
- | anyBot (absEval AbsAnal body env) = AbsBot
+widen AbsAnal (AbsFun arg body env)
+ | anyBot abs_body = AbsBot
-- In the absence-analysis case it's *essential* to check
-- that the function has no poison in its body. If it does,
-- anywhere, then the whole function is poisonous.
| otherwise
- = ASSERT (not (null args))
- AbsApproxFun (map (findDemandAbsOnly env body) args)
+ = AbsApproxFun (findDemandAbsOnly env body arg)
+ (widen AbsAnal abs_body)
+ where
+ abs_body = absEval AbsAnal body env
widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
sameVal (AbsProd _) AbsTop = False
sameVal (AbsProd _) AbsBot = False
-sameVal (AbsApproxFun str1) (AbsApproxFun str2) = str1 == str2
-sameVal (AbsApproxFun _) AbsTop = False
-sameVal (AbsApproxFun _) AbsBot = False
+sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v1
+sameVal (AbsApproxFun _ _) AbsTop = False
+sameVal (AbsApproxFun _ _) AbsBot = False
sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered"
\end{code}
(Just abs_val, _, _) ->
abs_val -- Bound in the environment
- (Nothing, noStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) ->
+ (Nothing, NoStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) ->
-- We have an unfolding for the expr
-- Assume the unfolding has no free variables since it
-- came from inside the Id
\begin{code}
absEval anal (Lam (ValBinder binder) body) env
- = AbsFun [binder] body env
+ = AbsFun binder body env
absEval anal (Lam other_binder expr) env
= absEval anal expr env
absEval anal (App f a) env | isValArg a
an augmented environment.
\begin{code}
-absApply anal (AbsFun [binder] body env) arg
+absApply anal (AbsFun binder body env) arg
= absEval anal body (addOneToAbsValEnv env binder arg)
-
-absApply anal (AbsFun (binder:bs) body env) arg
- = AbsFun bs body (addOneToAbsValEnv env binder arg)
\end{code}
\begin{code}
-absApply StrAnal (AbsApproxFun (arg1_demand:ds)) arg
- = if evalStrictness arg1_demand arg
+absApply StrAnal (AbsApproxFun demand val) arg
+ = if evalStrictness demand arg
then AbsBot
- else case ds of
- [] -> AbsTop
- other -> AbsApproxFun ds
+ else val
-absApply AbsAnal (AbsApproxFun (arg1_demand:ds)) arg
- = if evalAbsence arg1_demand arg
+absApply AbsAnal (AbsApproxFun demand val) arg
+ = if evalAbsence demand arg
then AbsBot
- else case ds of
- [] -> AbsTop
- other -> AbsApproxFun ds
+ else val
#ifdef DEBUG
-absApply anal (AbsApproxFun []) arg = panic ("absApply: Duff function: AbsApproxFun." ++ show anal)
-absApply anal (AbsFun [] _ _) arg = panic ("absApply: Duff function: AbsFun." ++ show anal)
absApply anal (AbsProd _) arg = panic ("absApply: Duff function: AbsProd." ++ show anal)
#endif
\end{code}
-- AbsProd [AbsBot, ..., AbsBot]
| AbsFun -- An abstract function, with the given:
- [Id] -- arguments
- CoreExpr -- body
+ Id -- argument
+ CoreExpr -- body
AbsValEnv -- and environment
| AbsApproxFun -- This is used to represent a coarse
- [Demand] -- approximation to a function value. It's an
- -- abstract function which is strict in its i'th
- -- argument if the i'th element of the Demand
- -- list so indicates.
- -- The list of arguments is always non-empty.
- -- In effect, AbsApproxFun [] = AbsTop
+ Demand -- approximation to a function value. It's an
+ AbsVal -- abstract function which is strict in its
+ -- argument if the Demand so indicates.
instance Outputable AbsVal where
ppr sty AbsTop = ppStr "AbsTop"
ppr sty AbsBot = ppStr "AbsBot"
ppr sty (AbsProd prod) = ppCat [ppStr "AbsProd", ppr sty prod]
- ppr sty (AbsFun args body env)
- = ppCat [ppStr "AbsFun{", ppr sty args,
+ ppr sty (AbsFun arg body env)
+ = ppCat [ppStr "AbsFun{", ppr sty arg,
ppStr "???", -- ppStr "}{env:", ppr sty (keysFM env `zip` eltsFM env),
ppStr "}" ]
- ppr sty (AbsApproxFun demands)
- = ppCat [ppStr "AbsApprox{", ppr sty demands, ppStr "}" ]
+ ppr sty (AbsApproxFun demand val)
+ = ppCat [ppStr "AbsApprox ", ppr sty demand, ppStr "", ppr sty val ]
\end{code}
%-----------
absValFromStrictness StrAnal BottomGuaranteed = AbsBot -- Guaranteed bottom
absValFromStrictness AbsAnal BottomGuaranteed = AbsTop -- Check for poison in
-- arguments (if any)
-absValFromStrictness anal (StrictnessInfo [] _) = AbsTop
-absValFromStrictness anal (StrictnessInfo args_info _) = AbsApproxFun args_info
+absValFromStrictness anal (StrictnessInfo args_info _) = foldr AbsApproxFun AbsTop args_info
\end{code}
= binder `addIdStrictness` mkBottomStrictnessInfo
| otherwise
- = case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
- let
- tys = map idType lambda_bounds
- strictness = findStrictness strflags tys str_val abs_val
- in
- binder `addIdStrictness` mkStrictnessInfo strictness Nothing
- }
+ = case (collectBinders body) of
+ (_, _, [], rhs) -> binder
+ (_, _, lambda_bounds, rhs) -> binder `addIdStrictness`
+ mkStrictnessInfo strictness Nothing
+ where
+ tys = map idType lambda_bounds
+ strictness = findStrictness strflags tys str_val abs_val
\end{code}
\begin{code}
case (maybeAppDataTyConExpandingDicts arg_ty) of
- Nothing -> -- Not a data type
- panic "mk_ww_arg_processing: not datatype"
-
- Just (_, _, []) -> -- An abstract type
- -- We have to give up on the whole idea
- returnUs Nothing
-
- Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd
- panic "mk_ww_arg_processing: multi-constr"
+ Nothing -> -- Not a data type
+ panic "mk_ww_arg_processing: not datatype"
Just (arg_tycon, tycon_arg_tys, [data_con]) ->
- -- The main event: a single-constructor data type
-
- let
- inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
- in
- getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
-
- let
- unpk_args = zipWithEqual "mk_ww_arg_processing"
- (\ u t -> mkSysLocal SLIT("upk") u t noSrcLoc)
- uniqs inst_con_arg_tys
- in
- -- In processing the rest, push the sub-component args
- -- and infos on the front of the current bunch
- mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) True {- useful split -} new_max_extra_args
- `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
+ -- The main event: a single-constructor data type
+ do_single_constr arg_tycon tycon_arg_tys data_con
+
+ Just (_, _, data_cons) -> -- Zero, or two or more constructors; that's odd
+ panic "mk_ww_arg_processing: not one constr"
- returnUs (Just (
- -- wrapper: unpack the value
- \ hole -> mk_unpk_case arg unpk_args
- data_con arg_tycon
- (wrap_rest hole),
-
- -- worker: expect the unpacked value;
- -- reconstruct the orig value with a "let"
- work_args_info,
- \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole)
- ))
where
arg_ty = idType arg
+ 1 -- We won't pass the original arg now
- nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt
+ do_single_constr arg_tycon tycon_arg_tys data_con
+ = let
+ inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
+ in
+ getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
+
+ let
+ unpk_args = zipWithEqual "mk_ww_arg_processing"
+ (\ u t -> mkSysLocal SLIT("upk") u t noSrcLoc)
+ uniqs inst_con_arg_tys
+ in
+ -- In processing the rest, push the sub-component args
+ -- and infos on the front of the current bunch
+ mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) True {- useful split -} new_max_extra_args
+ `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
+
+ returnUs (Just (
+ -- wrapper: unpack the value
+ \ hole -> mk_unpk_case arg unpk_args
+ data_con arg_tycon
+ (wrap_rest hole),
+
+ -- worker: expect the unpacked value;
+ -- reconstruct the orig value with a "let"
+ work_args_info,
+ \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole)
+ ))
+
mk_unpk_case arg unpk_args boxing_con boxing_tycon body
= Case (Var arg) (
AlgAlts [(boxing_con, unpk_args, body)]
--)
nonAbsentArgs :: [Demand] -> Int
-nonAbsentArgs cmpts = length [() | WwLazy True <- cmpts]
+nonAbsentArgs [] = 0
+nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds
+nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
\end{code}
-> NF_TcM s (LIE s, [TcIdOcc s])
newDicts orig theta
= tcGetSrcLoc `thenNF_Tc` \ loc ->
+ newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, ids) ->
+ returnNF_Tc (listToBag dicts, ids)
+{-
tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
let
mk_dict u (clas, ty) = Dict u clas ty orig loc
dicts = zipWithEqual "newDicts" mk_dict new_uniqs theta
in
returnNF_Tc (listToBag dicts, map instToId dicts)
-
-newDictsAtLoc orig loc theta -- Local function, similar to newDicts,
- -- but with slightly different interface
- = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
- let
- mk_dict u (clas, ty) = Dict u clas ty orig loc
- dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
- in
- returnNF_Tc (dicts, map instToId dicts)
+-}
+
+-- Local function, similar to newDicts,
+-- but with slightly different interface
+newDictsAtLoc :: InstOrigin s
+ -> SrcLoc
+ -> [(Class, TcType s)]
+ -> NF_TcM s ([Inst s], [TcIdOcc s])
+newDictsAtLoc orig loc theta =
+ tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
+ let
+ mk_dict u (clas, ty) = Dict u clas ty orig loc
+ dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
+ in
+ returnNF_Tc (dicts, map instToId dicts)
newMethod :: InstOrigin s
-> TcIdOcc s
import HsSyn ( HsDecl, FixityDecl, Fixity, InstDecl,
Sig, HsBinds(..), Bind(..), MonoBinds(..),
GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
- ArithSeqInfo, Fake, HsType
+ ArithSeqInfo, Fake, HsType,
+ collectMonoBinders
)
import HsPragmas ( InstancePragmas(..) )
import RdrHsSyn ( RdrName, SYN_IE(RdrNameMonoBinds) )
import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
-import RnEnv ( newDfunName )
+import RnEnv ( newDfunName, bindLocatedLocalsRn )
import RnMonad ( SYN_IE(RnM), RnDown, GDown, SDown, RnNameSupply(..),
setNameSupplyRn, renameSourceCode, thenRn, mapRn, returnRn )
import TyVar ( GenTyVar )
import UniqFM ( emptyUFM )
import Unique -- Keys stuff
+import Bag ( bagToList )
import Util ( zipWithEqual, zipEqual, sortLt, removeDups, assoc,
thenCmp, cmpList, panic, panic#, pprPanic, pprPanic#,
assertPanic-- , pprTrace{-ToDo:rm-}
extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
method_binds_s = map gen_bind new_inst_infos
+ mbinders = bagToList (collectMonoBinders extra_mbinds)
-- Rename to get RenamedBinds.
-- The only tricky bit is that the extra_binds must scope over the
-- method bindings for the instances.
(dfun_names_w_method_binds, rn_extra_binds)
= renameSourceCode modname rn_name_supply (
+ bindLocatedLocalsRn "deriving" mbinders $ \ _ ->
rnTopMonoBinds extra_mbinds [] `thenRn` \ rn_extra_binds ->
mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds ->
returnRn (dfun_names_w_method_binds, rn_extra_binds)
)
rn_one meth_binds = newDfunName mkGeneratedSrcLoc `thenRn` \ dfun_name ->
- rnMethodBinds meth_binds `thenRn` \ rn_meth_binds ->
+ rnMethodBinds meth_binds `thenRn` \ rn_meth_binds ->
returnRn (dfun_name, rn_meth_binds)
in
mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
- returnTc (HsCon stDataCon [realWorldTy, result_ty] [CCall lbl args' may_gc is_asm result_ty],
- -- do the wrapping in the newtype constructor here
+ returnTc (HsApp (HsVar (RealId stDataCon) `TyApp` [realWorldTy, result_ty])
+ (CCall lbl args' may_gc is_asm result_ty),
+ -- do the wrapping in the newtype constructor here
foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
mkPrimIoTy result_ty)
\end{code}
dataConRawArgTys, fIRST_TAG,
isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) )
import Maybes ( maybeToBool )
-import Name ( getOccString, getSrcLoc, occNameString, modAndOcc, OccName, Name )
+import Name ( getOccString, getOccName, getSrcLoc, occNameString, modAndOcc, OccName, Name )
import PrimOp ( PrimOp(..) )
import PrelInfo -- Lots of RdrNames
con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
+con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
+tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
+maxtag_RDR tycon = varUnqual (SLIT("maxtag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
+
+
+{- OLD, and wrong; the renamer doesn't like qualified names for locals.
+
con2tag_RDR tycon
= let (mod, nm) = modAndOcc tycon
con2tag = SLIT("con2tag_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
maxtag = SLIT("maxtag_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
in
varQual (mod, maxtag)
+-}
\end{code}
zonkExpr te ve (SingleDict name)
= returnNF_Tc (SingleDict (zonkIdOcc ve name))
-zonkExpr te ve (HsCon con tys vargs)
- = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
- mapNF_Tc (zonkExpr te ve) vargs `thenNF_Tc` \ new_vargs ->
- returnNF_Tc (HsCon con new_tys new_vargs)
-------------------------------------------------------------------------
zonkArithSeq :: TyVarEnv Type -> IdEnv Id
import TcMonad
import TcMonoType ( tcHsType )
-import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv )
+import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv,
+ tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue
+ )
import TcKind ( TcKind, kindToTcKind )
import HsSyn ( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDecl, HsBinds,
import RnHsSyn ( RenamedHsDecl(..) )
import HsCore
import HsDecls ( HsIdInfo(..) )
+import Literal ( Literal(..) )
import CoreSyn
import CoreUnfold
import MagicUFs ( MagicUnfoldingFun )
import PrimOp ( PrimOp(..) )
import Id ( GenId, mkImported, mkUserId, isPrimitiveId_maybe )
+import Type ( mkSynTy )
import TyVar ( mkTyVar )
import Name ( Name )
+import Unique ( rationalTyConKey )
+import TysWiredIn ( integerTy )
import PragmaInfo ( PragmaInfo(..) )
+import ErrUtils ( pprBagOfErrors )
import Maybes ( maybeToBool )
import Pretty
import PprStyle ( PprStyle(..) )
tcInterfaceSigs [] = returnTc []
\end{code}
-Inside here we use only the Global environment, even for locally bound variables.
-Why? Because we know all the types and want to bind them to real Ids.
-
\begin{code}
tcIdInfo name info [] = returnTc info
\begin{code}
tcStrictness (StrictnessInfo demands (Just worker))
- = tcLookupGlobalValue worker `thenNF_Tc` \ worker_id ->
- returnTc (StrictnessInfo demands (Just worker_id))
+ = tcWorker worker `thenNF_Tc` \ maybe_worker_id ->
+ returnTc (StrictnessInfo demands maybe_worker_id)
-- Boring to write these out, but the result type differe from the arg type...
tcStrictness (StrictnessInfo demands Nothing) = returnTc (StrictnessInfo demands Nothing)
tcStrictness BottomGuaranteed = returnTc BottomGuaranteed
\end{code}
+\begin{code}
+tcWorker worker
+ = tcLookupGlobalValueMaybe worker `thenNF_Tc` \ maybe_worker_id ->
+ returnNF_Tc (trace_maybe maybe_worker_id)
+ where
+ -- The trace is so we can see what's getting dropped
+ trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr PprDebug worker) Nothing
+ trace_maybe (Just x) = Just x
+\end{code}
+
+tcLookupGlobalValue worker
+
For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
\begin{code}
tcUnfolding name core_expr
= forkNF_Tc (
- recoverNF_Tc (returnNF_Tc no_unfolding) (
+ recoverNF_Tc no_unfolding (
tcCoreExpr core_expr `thenTc` \ core_expr' ->
returnTc (mkUnfolding False core_expr')
))
where
- no_unfolding = pprTrace "tcUnfolding failed:" (ppr PprDebug name) NoUnfolding
+ -- The trace tells what wasn't available, for the benefit of
+ -- compiler hackers who want to improve it!
+ no_unfolding = getErrsTc `thenNF_Tc` \ (warns,errs) ->
+ returnNF_Tc (pprTrace "tcUnfolding failed with:"
+ (ppHang (ppr PprDebug name) 4 (pprBagOfErrors PprDebug errs))
+ NoUnfolding)
+\end{code}
+
+
+Variables in unfoldings
+~~~~~~~~~~~~~~~~~~~~~~~
+****** Inside here we use only the Global environment, even for locally bound variables.
+****** Why? Because we know all the types and want to bind them to real Ids.
+
+\begin{code}
+tcVar :: Name -> TcM s Id
+tcVar name
+ = tcLookupGlobalValueMaybe name `thenNF_Tc` \ maybe_id ->
+ case maybe_id of {
+ Just id -> returnTc id;
+ Nothing -> failTc (noDecl name)
+ }
+
+noDecl name sty = ppCat [ppStr "Warning: no binding for", ppr sty name]
\end{code}
UfCore expressions.
tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
tcCoreExpr (UfVar name)
- = tcLookupGlobalValue name `thenNF_Tc` \ id ->
+ = tcVar name `thenTc` \ id ->
returnTc (Var id)
-tcCoreExpr (UfLit lit) = returnTc (Lit lit)
+-- rationalTy isn't built in so we have to construct it
+-- (the "ty" part of the incoming literal is simply bottom)
+tcCoreExpr (UfLit (NoRepRational lit _))
+ = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
+ let
+ rational_ty = mkSynTy rational_tycon []
+ in
+ returnTc (Lit (NoRepRational lit rational_ty))
+
+-- Similarly for integers, except that it is wired in
+tcCoreExpr (UfLit (NoRepInteger lit _))
+ = returnTc (Lit (NoRepInteger lit integerTy))
+
+tcCoreExpr (UfLit other_lit)
+ = returnTc (Lit other_lit)
tcCoreExpr (UfCon con args)
- = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
+ = tcVar con `thenTc` \ con_id ->
mapTc tcCoreArg args `thenTc` \ args' ->
returnTc (Con con_id args')
\end{code}
\begin{code}
-tcCoreArg (UfVarArg v) = tcLookupGlobalValue v `thenNF_Tc` \ v' -> returnTc (VarArg v')
-tcCoreArg (UfTyArg ty) = tcHsType ty `thenTc` \ ty' -> returnTc (TyArg ty')
+tcCoreArg (UfVarArg v) = tcVar v `thenTc` \ v' -> returnTc (VarArg v')
+tcCoreArg (UfTyArg ty) = tcHsType ty `thenTc` \ ty' -> returnTc (TyArg ty')
tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage"
tcCoreDefault deflt `thenTc` \ deflt' ->
returnTc (AlgAlts alts' deflt')
where
- tc_alt (con, bndrs, rhs) = tcLookupGlobalValue con `thenNF_Tc` \ con' ->
+ tc_alt (con, bndrs, rhs) = tcVar con `thenTc` \ con' ->
tcCoreValBndrs bndrs $ \ bndrs' ->
tcCoreExpr rhs `thenTc` \ rhs' ->
returnTc (con', bndrs', rhs')
tcCoreExpr rhs `thenTc` \ rhs' ->
returnTc (BindDefault bndr' rhs')
-tcCoercion (UfIn n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceIn n')
-tcCoercion (UfOut n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceOut n')
+tcCoercion (UfIn n) = tcVar n `thenTc` \ n' -> returnTc (CoerceIn n')
+tcCoercion (UfOut n) = tcVar n `thenTc` \ n' -> returnTc (CoerceOut n')
tcCorePrim (UfOtherOp op)
- = tcLookupGlobalValue op `thenNF_Tc` \ op_id ->
+ = tcVar op `thenTc` \ op_id ->
case isPrimitiveId_maybe op_id of
Just prim_op -> returnTc prim_op
Nothing -> pprPanic "tcCorePrim" (ppr PprDebug op_id)
import SrcLoc ( SrcLoc )
import Pretty
import TyCon ( isSynTyCon, derivedFor )
-import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
+import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType,
splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
getTyCon_maybe, maybeAppTyCon,
maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy
-- These conditions come directly from what the DsCCall is capable of.
-- Totally grotesque. Green card should solve this.
-ccallable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
+ccallable_type ty = isPrimType ty || -- Allow CCallable Int# etc
+ maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc
ty `eqTy` stringTy ||
byte_arr_thing
where
initTc,
returnTc, thenTc, thenTc_, mapTc, listTc,
foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
- mapBagTc, fixTc, tryTc,
+ mapBagTc, fixTc, tryTc, getErrsTc,
returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc,
Error handling
~~~~~~~~~~~~~~
\begin{code}
+getErrsTc :: NF_TcM s (Bag Error, Bag Warning)
+getErrsTc down env
+ = readMutVarSST errs_var
+ where
+ errs_var = getTcErrs down
+
failTc :: Message -> TcM s a
failTc err_msg down env
= readMutVarSST errs_var `thenSST` \ (warns,errs) ->
%* *
%************************************************************************
+Precedence
+~~~~~~~~~~
+@ppr_ty@ takes an @Int@ that is the precedence of the context.
+The precedence levels are:
+\begin{description}
+\item[tOP_PREC] No parens required.
+\item[fUN_PREC] Left hand argument of a function arrow.
+\item[tYCON_PREC] Argument of a type constructor.
+\end{description}
+
+
+\begin{code}
+tOP_PREC = (0 :: Int)
+fUN_PREC = (1 :: Int)
+tYCON_PREC = (2 :: Int)
+
+maybeParen ctxt_prec inner_prec pretty
+ | ctxt_prec < inner_prec = pretty
+ | otherwise = ppParens pretty
+\end{code}
+
@pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
defined to use this. @pprParendGenType@ is the same, except it puts
parens around the type, except for the atomic cases. @pprParendGenType@
= ppr_tycon env tycon
ppr_ty env ctxt_prec ty@(ForAllTy _ _)
- | show_forall = ppSep [ ppPStr SLIT("_forall_"), pp_tyvars,
+ | show_forall = maybeParen ctxt_prec fUN_PREC $
+ ppSep [ ppPStr SLIT("_forall_"), pp_tyvars,
pp_theta, ppPStr SLIT("=>"), pp_body
]
- | null theta = pp_body
- | otherwise = ppSep [pp_theta, ppPStr SLIT("=>"), pp_body]
+ | null theta = ppr_ty env ctxt_prec body_ty
+ | otherwise = maybeParen ctxt_prec fUN_PREC $
+ ppSep [pp_theta, ppPStr SLIT("=>"), pp_body]
where
(tyvars, rho_ty) = splitForAllTy ty
(theta, body_ty) | show_context = splitRhoTy rho_ty
pp_tyvars = ppBracket (ppIntersperse ppSP (map (pTyVarB env) tyvars))
pp_theta | null theta = ppNil
| otherwise = ppCurlies (ppInterleave ppComma (map (ppr_dict env tOP_PREC) theta))
- pp_body = ppr_ty env ctxt_prec body_ty
+ pp_body = ppr_ty env tOP_PREC body_ty
sty = pStyle env
show_forall = case sty of
ppr_class env clas = ppr (pStyle env) clas
\end{code}
-@ppr_ty@ takes an @Int@ that is the precedence of the context.
-The precedence levels are:
-\begin{description}
-\item[0:] What we start with.
-\item[1:] Function application (@FunTys@).
-\item[2:] Type constructors.
-\end{description}
-
-
-\begin{code}
-tOP_PREC = (0 :: Int)
-fUN_PREC = (1 :: Int)
-tYCON_PREC = (2 :: Int)
-
-maybeParen ctxt_prec inner_prec pretty
- | ctxt_prec < inner_prec = pretty
- | otherwise = ppParens pretty
-\end{code}
-
%************************************************************************
%* *
\subsection[TyVar]{@TyVar@}
Instantiating a type
~~~~~~~~~~~~~~~~~~~~
\begin{code}
-applyTy :: GenType (GenTyVar flexi) uvar
- -> GenType (GenTyVar flexi) uvar
- -> GenType (GenTyVar flexi) uvar
+-- applyTy :: GenType (GenTyVar flexi) uvar
+-- -> GenType (GenTyVar flexi) uvar
+-- -> GenType (GenTyVar flexi) uvar
-applyTy (SynTy _ _ fun) arg = applyTy fun arg
-applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
-applyTy other arg = panic "applyTy"
+applyTy :: Type -> Type -> Type
+
+applyTy (SynTy _ _ fun) arg = applyTy fun arg
+applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
+applyTy ty@(DictTy _ _ _) arg = applyTy (expandTy ty) arg
+applyTy other arg = panic "applyTy"
\end{code}
\begin{code}
import Maybes
import Bag ( Bag, foldBag )
import Outputable ( Outputable(..) )
-
-# ifdef DEBUG
import PprStyle ( PprStyle )
import Pretty ( SYN_IE(Pretty), PrettyRep )
-# endif
#ifdef COMPILING_GHC
, FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
, FiniteMap (FAST_STRING, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt
, FiniteMap RdrName elt -> RdrName -> elt -> FiniteMap RdrName elt
- , FiniteMap OrigName elt -> OrigName -> elt -> FiniteMap OrigName elt
IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
#-}
{-# SPECIALIZE addToFM_C
:: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt
- , (elt -> elt -> elt) -> FiniteMap (OrigName, OrigName) elt -> (OrigName, OrigName) -> elt -> FiniteMap (OrigName, OrigName) elt
, (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
#-}
#-}
{-# SPECIALIZE delListFromFM
:: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt
- , FiniteMap OrigName elt -> [OrigName] -> FiniteMap OrigName elt
, FiniteMap FAST_STRING elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt
IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt)
#-}
:: [([Char],elt)] -> FiniteMap [Char] elt
, [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt
, [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
- , [(OrigName,elt)] -> FiniteMap OrigName elt
IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt)
#-}
{-# SPECIALIZE lookupFM
, FiniteMap [Char] elt -> [Char] -> Maybe elt
, FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt
, FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt
- , FiniteMap OrigName elt -> OrigName -> Maybe elt
- , FiniteMap (OrigName,OrigName) elt -> (OrigName,OrigName) -> Maybe elt
, FiniteMap RdrName elt -> RdrName -> Maybe elt
, FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt
IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt)
#-}
{-# SPECIALIZE plusFM
:: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt
- , FiniteMap OrigName elt -> FiniteMap OrigName elt -> FiniteMap OrigName elt
, FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
#-}
interface SpecLoop where
import RdrHsSyn ( RdrName )
-import Name ( Name, OrigName, OccName )
+import Name ( Name, OccName )
import TyVar ( GenTyVar )
import TyCon ( TyCon )
import Class ( GenClass, GenClassOp )
data GenId a -- NB: fails the optimisation criterion
data GenTyVar a -- NB: fails the optimisation criterion
data Name
-data OrigName
data OccName
data TyCon
data Unique
instance Eq CLabel
instance Eq OccName
instance Eq RdrName
-instance Eq OrigName
instance Eq (GenId a)
instance Eq TyCon
instance Eq (GenClass a b)
instance Ord CLabel
instance Ord OccName
instance Ord RdrName
-instance Ord OrigName
instance Ord (GenId a)
instance Ord TyCon
instance Ord (GenClass a b)
instance Ord Name
-- SPECIALIZing in UniqFM, UniqSet
-instance Uniquable OrigName
instance Uniquable (GenId a)
instance Uniquable TyCon
instance Uniquable (GenClass a b)
Name Module
Name Name
Name NamedThing (..)
-Name OrigName (..)
Name RdrName (..)
Outputable Outputable (..)
PprStyle PprStyle
The types are: list, @Bool@, @Char@, @Ordering@, @String@, @Int@, @Integer@, @Maybe@, @Either@.
\item @PrelTup@: defines tuples and their instances.
-\item @PrelList@: defines most of the list operations required by @Prelude@. (A few are in @PrelBase@.
+\item @PrelList@: defines most of the list operations required by @Prelude@. (A few are in @PrelBase@,
+to avoid gratuitous mutual recursion between modules.)
\item @PrelNum@ defines: the numeric classes beyond @Num@ (namely @Real@, @Integral@,
@Fractional@, @Floating@, @RealFrac@, @RealFloat@; instances for appropriate classes
\item @IOBase@: substrate stuff for the main I/O libraries.
\item @IOHandle@: large blob of code for doing I/O on handles.
\item @PrelIO@: the remaining small pieces to produce the I/O stuff needed by @Prelude@.
+
+\item @STBase@: substrate stuff for @ST@.
+\item @ArrBase@: substrate stuff for @Array@.
+
\item @GHCerr@: error reporting code, called from code that the compiler plants in compiled programs.
\item @GHCmain@: the definition of @mainPrimIO@, which is what {\em really} gets
called by the runtime system. @mainPrimIO@ in turn calls @main@.
\end{itemize}
\end{description}
+The @...Base@ modules generally export representation information that
+is hidden from the public interface. For example the module @STBase@
+exports the type @ST@ including its representation, whereas the module
+@ST@ exports @ST@ abstractly.
+
+None of these modules are involved in any mutual recursion, with the sole exception that
+many modules import @IOBase.error@.
+
\section{The module @GHC@: really primitive stuff}
\label{sect:ghc}
local($new_hi) = "$Tmp_prefix.hi-new";
-# print STDERR `$Cat $hsc_hi`;
+ print STDERR "*** New hi file follows...\n"
+ print STDERR `$Cat $hsc_hi`;
&constructNewHiFile($hsc_hi, $hifile_target, $new_hi);
which are filled in later, using these.
These are the default values, which may be changed by user flags.
\begin{code}
-$Oopt_UnfoldingUseThreshold = '-fsimpl-uf-use-threshold3';
+$Oopt_UnfoldingUseThreshold = '-funfolding-use-threshold3';
$Oopt_MaxSimplifierIterations = '-fmax-simplifier-iterations4';
$Oopt_PedanticBottoms = '-fpedantic-bottoms'; # ON by default
$Oopt_MonadEtaExpansion = '';
/^-fno-implicit-prelude$/ && do { $NoImplicitPrelude= 1; push(@HsC_flags, $_); next arg; };
- # ToDo: rename to -fcompiling-ghc-internals=<module>
- # NB: not documented
- /^-fcompiling-ghc-internals(.*)/ && do { local($m) = &grab_arg_arg('-fcompiling-ghc-internals',$1);
- push(@HsC_flags, "-fcompiling-ghc-internals=$m");
- next arg; };
-
- # NB: not really put to use and not documented
- /^-fusing-ghc-internals$/ && do { $UsingGhcInternals = 1; next arg; };
-
/^-user-prelude-force/ && do { # ignore if not -user-prelude
next arg; };
# ---------------
- /^(-fsimpl-uf-use-threshold)(.*)$/
+ /^(-funfolding-use-threshold)(.*)$/
&& do { $Oopt_UnfoldingUseThreshold = $1 . &grab_arg_arg($1, $2);
next arg; };
@HsC_minusO_flags # NOTE: used for *both* -O and -O2 (some conditional bits)
= (
+ '-fdo-eta-reduction',
+
# initial simplify: mk specialiser happy: minimum effort please
'-fsimplify',
'\(',
'-fcase-of-case',
'-fdo-case-elim',
'-fcase-merge',
- '-fdo-eta-reduction',
'-fdo-lambda-eta-expansion',
'-freuse-con',
$Oopt_PedanticBottoms,
# '-fcase-of-case',
# '-fdo-case-elim',
# '-fcase-merge',
-# '-fdo-eta-reduction',
# '-fdo-lambda-eta-expansion',
# '-freuse-con',
# $Oopt_PedanticBottoms,
'-fcase-of-case',
'-fdo-case-elim',
'-fcase-merge',
- '-fdo-eta-reduction',
'-fdo-lambda-eta-expansion', # After full laziness
'-freuse-con',
$Oopt_PedanticBottoms,
'-fcase-of-case',
'-fdo-case-elim',
'-fcase-merge',
- '-fdo-eta-reduction',
'-fdo-lambda-eta-expansion',
'-freuse-con',
($Oopt_FoldrBuildInline),
'-fcase-of-case',
'-fdo-case-elim',
'-fcase-merge',
- '-fdo-eta-reduction',
'-fdo-lambda-eta-expansion',
'-freuse-con',
'-flet-to-case', # Aha! Only done after strictness analysis
# ( ($OptLevel != 2)
# ? ''
-# : "-fliberate-case -fsimplify \\( $Oopt_FB_Support -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fcase-merge -fdo-eta-reduction -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MonadEtaExpansion $Oopt_UnfoldingUseThreshold $Oopt_MaxSimplifierIterations \\)" ),
+# : "-fliberate-case -fsimplify \\( $Oopt_FB_Support -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fcase-merge -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MonadEtaExpansion $Oopt_UnfoldingUseThreshold $Oopt_MaxSimplifierIterations \\)" ),
# Final clean-up simplification:
'-fcase-of-case',
'-fdo-case-elim',
'-fcase-merge',
- '-fdo-eta-reduction',
'-fdo-lambda-eta-expansion',
'-freuse-con',
'-flet-to-case',
#-----------------------------------------------------------------------------
-# $Id: Makefile.libHS,v 1.3 1996/12/19 09:13:56 simonpj Exp $
+# $Id: Makefile.libHS,v 1.4 1997/01/06 21:10:03 simonpj Exp $
TOP = ../..
include $(TOP)/ghc/mk/ghc.mk
# The driver will give warnings if -split-objs, but that's cool...
GHC_OPTS = \
- -recomp -cpp -dcore-lint -fglasgow-exts -fvia-C \
+ -recomp -cpp -fglasgow-exts -fvia-C \
$(HcMaxHeapFlag) $(EXTRA_HC_OPTS)
SRCS = $(wildcard ghc/*.lhs required/*.lhs glaExts/*.lhs concurrent/*.lhs)
\section[ArrBase]{Module @ArrBase@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module ArrBase where
-import Prelude ()
-import IOBase ( error ) {-# SOURCE #-}
+import {#- SOURCE #-} IOBase ( error )
import Ix
import PrelList
import STBase
_interface_ GHC 2
_exports_
-
-GHC Void
-GHC void
+GHC
+ Void
+ void
-- I/O primitives
-GHC RealWorld
-GHC realWorld#
-GHC State#
-
-GHC fork#
-GHC delay#
-
-GHC SynchVar#
-GHC newSynchVar#
-GHC takeMVar#
-GHC putMVar#
-GHC waitRead#
-GHC waitWrite#
-
-GHC errorIO#
-
-GHC Char#
-GHC gtChar#
-GHC geChar#
-GHC eqChar#
-GHC neChar#
-GHC ltChar#
-GHC leChar#
-GHC ord#
-GHC chr#
-
-GHC Int#
-GHC >#
-GHC >=#
-GHC ==#
-GHC /=#
-GHC <#
-GHC <=#
-GHC +#
-GHC -#
-GHC *#
-GHC quotInt#
-GHC remInt#
-GHC negateInt#
-GHC iShiftL#
-GHC iShiftRA#
-GHC iShiftRL#
-
-GHC Word#
-GHC gtWord#
-GHC geWord#
-GHC eqWord#
-GHC neWord#
-GHC ltWord#
-GHC leWord#
-GHC and#
-GHC or#
-GHC not#
-GHC shiftL#
-GHC shiftRA#
-GHC shiftRL#
-GHC int2Word#
-GHC word2Int#
-
-GHC Addr#
-GHC gtAddr#
-GHC geAddr#
-GHC eqAddr#
-GHC neAddr#
-GHC ltAddr#
-GHC leAddr#
-GHC int2Addr#
-GHC addr2Int#
-
-GHC Float#
-GHC gtFloat#
-GHC geFloat#
-GHC eqFloat#
-GHC neFloat#
-GHC ltFloat#
-GHC leFloat#
-GHC plusFloat#
-GHC minusFloat#
-GHC timesFloat#
-GHC divideFloat#
-GHC negateFloat#
-GHC float2Int#
-GHC int2Float#
-GHC expFloat#
-GHC logFloat#
-GHC sqrtFloat#
-GHC sinFloat#
-GHC cosFloat#
-GHC tanFloat#
-GHC asinFloat#
-GHC acosFloat#
-GHC atanFloat#
-GHC sinhFloat#
-GHC coshFloat#
-GHC tanhFloat#
-GHC powerFloat#
-GHC decodeFloat#
-GHC encodeFloat#
-
-GHC Double#
-GHC >##
-GHC >=##
-GHC ==##
-GHC /=##
-GHC <##
-GHC <=##
-GHC +##
-GHC -##
-GHC *##
-GHC /##
-GHC negateDouble#
-GHC double2Int#
-GHC int2Double#
-GHC double2Float#
-GHC float2Double#
-GHC expDouble#
-GHC logDouble#
-GHC sqrtDouble#
-GHC sinDouble#
-GHC cosDouble#
-GHC tanDouble#
-GHC asinDouble#
-GHC acosDouble#
-GHC atanDouble#
-GHC sinhDouble#
-GHC coshDouble#
-GHC tanhDouble#
-GHC **##
-GHC decodeDouble#
-GHC encodeDouble#
-
-GHC cmpInteger#
-GHC negateInteger#
-GHC plusInteger#
-GHC minusInteger#
-GHC timesInteger#
-GHC quotRemInteger#
-GHC integer2Int#
-GHC int2Integer#
-
-GHC indexArray#
-
-GHC Array#
-GHC ByteArray#
-GHC MutableArray#
-GHC MutableByteArray#
-
-GHC sameMutableArray#
-
-GHC newArray#
-GHC newCharArray#
-GHC newIntArray#
-GHC newFloatArray#
-GHC newDoubleArray#
-GHC newAddrArray#
-
-GHC indexArray#
-GHC indexCharArray#
-GHC indexIntArray#
-GHC indexFloatArray#
-GHC indexDoubleArray#
-GHC indexAddrArray#
-
-GHC indexOffAddr#
-GHC indexCharOffAddr#
-GHC indexIntOffAddr#
-GHC indexFloatOffAddr#
-GHC indexDoubleOffAddr#
-GHC indexAddrOffAddr#
-
-GHC writeArray#
-GHC writeCharArray#
-GHC writeIntArray#
-GHC writeFloatArray#
-GHC writeDoubleArray#
-GHC writeAddrArray#
-
-GHC readArray#
-GHC readCharArray#
-GHC readIntArray#
-GHC readFloatArray#
-GHC readDoubleArray#
-GHC readAddrArray#
-
-GHC unsafeFreezeArray#
-GHC unsafeFreezeByteArray#
-
-GHC ForeignObj#
-GHC makeForeignObj#
-
-GHC StablePtr#
-GHC makeStablePtr#
-GHC deRefStablePtr#
-
+ RealWorld
+ realWorld#
+ State#
+
+ fork#
+ delay#
+
+ SynchVar#
+ newSynchVar#
+ takeMVar#
+ putMVar#
+ waitRead#
+ waitWrite#
+
+ errorIO#
+
+ Char#
+ gtChar#
+ geChar#
+ eqChar#
+ neChar#
+ ltChar#
+ leChar#
+ ord#
+ chr#
+
+ Int#
+ >#
+ >=#
+ ==#
+ /=#
+ <#
+ <=#
+ +#
+ -#
+ *#
+ quotInt#
+ remInt#
+ negateInt#
+ iShiftL#
+ iShiftRA#
+ iShiftRL#
+
+ Word#
+ gtWord#
+ geWord#
+ eqWord#
+ neWord#
+ ltWord#
+ leWord#
+ and#
+ or#
+ not#
+ shiftL#
+ shiftRA#
+ shiftRL#
+ int2Word#
+ word2Int#
+
+ Addr#
+ gtAddr#
+ geAddr#
+ eqAddr#
+ neAddr#
+ ltAddr#
+ leAddr#
+ int2Addr#
+ addr2Int#
+
+ Float#
+ gtFloat#
+ geFloat#
+ eqFloat#
+ neFloat#
+ ltFloat#
+ leFloat#
+ plusFloat#
+ minusFloat#
+ timesFloat#
+ divideFloat#
+ negateFloat#
+ float2Int#
+ int2Float#
+ expFloat#
+ logFloat#
+ sqrtFloat#
+ sinFloat#
+ cosFloat#
+ tanFloat#
+ asinFloat#
+ acosFloat#
+ atanFloat#
+ sinhFloat#
+ coshFloat#
+ tanhFloat#
+ powerFloat#
+ decodeFloat#
+ encodeFloat#
+
+ Double#
+ >##
+ >=##
+ ==##
+ /=##
+ <##
+ <=##
+ +##
+ -##
+ *##
+ /##
+ negateDouble#
+ double2Int#
+ int2Double#
+ double2Float#
+ float2Double#
+ expDouble#
+ logDouble#
+ sqrtDouble#
+ sinDouble#
+ cosDouble#
+ tanDouble#
+ asinDouble#
+ acosDouble#
+ atanDouble#
+ sinhDouble#
+ coshDouble#
+ tanhDouble#
+ **##
+ decodeDouble#
+ encodeDouble#
+
+ cmpInteger#
+ negateInteger#
+ plusInteger#
+ minusInteger#
+ timesInteger#
+ quotRemInteger#
+ integer2Int#
+ int2Integer#
+
+ indexArray#
+
+ Array#
+ ByteArray#
+ MutableArray#
+ MutableByteArray#
+
+ sameMutableArray#
+
+ newArray#
+ newCharArray#
+ newIntArray#
+ newFloatArray#
+ newDoubleArray#
+ newAddrArray#
+
+ indexArray#
+ indexCharArray#
+ indexIntArray#
+ indexFloatArray#
+ indexDoubleArray#
+ indexAddrArray#
+
+ indexOffAddr#
+ indexCharOffAddr#
+ indexIntOffAddr#
+ indexFloatOffAddr#
+ indexDoubleOffAddr#
+ indexAddrOffAddr#
+
+ writeArray#
+ writeCharArray#
+ writeIntArray#
+ writeFloatArray#
+ writeDoubleArray#
+ writeAddrArray#
+
+ readArray#
+ readCharArray#
+ readIntArray#
+ readFloatArray#
+ readDoubleArray#
+ readAddrArray#
+
+ unsafeFreezeArray#
+ unsafeFreezeByteArray#
+
+ ForeignObj#
+ makeForeignObj#
+
+ StablePtr#
+ makeStablePtr#
+ deRefStablePtr#
+;
\begin{code}
module GHCmain( mainPrimIO ) where
-import Prelude
import qualified Main -- for type of "Main.main"
import IOBase
import STBase
\begin{code}
#include "error.h"
+{-# OPTIONS -fno-implicit-prelude #-}
+
module IOBase where
-import Prelude ()
import STBase
import PrelTup
import Foreign
\begin{code}
#include "error.h"
+{-# OPTIONS -fno-implicit-prelude #-}
+
module IOHandle where
-import Prelude ()
import ST
import STBase
import ArrBase ( ByteArray(..) )
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PrelBase where
-import Prelude ()
-import IOBase ( error ) {-# SOURCE #-}
+import {-# SOURCE #-} IOBase ( error )
import GHC
infixr 9 ., !!
Input/output functions mandated by the standard Prelude.
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PrelIO (
IO, FilePath, IOError,
fail, userError, catch,
readFile, writeFile, appendFile, readIO, readLn
) where
-import Prelude ()
import IO
import IOHandle
import IOBase
The List data type and its operations
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PrelList (
[] (..),
zip, zip3, zipWith, zipWith3, unzip, unzip3
) where
-import Prelude ()
-import IOBase ( error ) {-# SOURCE #-}
+import {#- SOURCE #-} IOBase ( error )
import PrelTup
import PrelBase
-- e.g., x `elem` xs. notElem is the negation.
elem, notElem :: (Eq a) => a -> [a] -> Bool
elem x = any (== x)
-notElem x = all (not . (/= x))
+notElem x = all (/= x)
-- lookup key assocs looks up a key in an association list.
lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
\end{code}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PrelNum where
-import Prelude ()
-import IOBase ( error ) {-# SOURCE #-}
+import {#- SOURCE #-} IOBase ( error )
import PrelList
import PrelBase
import GHC
The @Read@ class and many of its instances.
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PrelRead where
-import Prelude ()
-import IOBase ( error ) {-# SOURCE #-}
+import {#- SOURCE #-} IOBase ( error )
import PrelNum
import PrelList
import PrelTup
This modules defines the typle data types.
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PrelTup where
-import Prelude ()
-import IOBase ( error )
+import {#- SOURCE #-} IOBase ( error )
import PrelBase
\end{code}
\section[STBase]{The @ST@ and @PrimIO@ monads}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module STBase where
-import Prelude ()
import Monad
import PrelBase
import GHC
\section[Foreign]{Module @Foreign@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module Foreign (
module Foreign,
Addr, Word
) where
-import Prelude ()
import STBase
import ArrBase
import PrelBase
class CReturnable a
instance CCallable Char
+instance CCallable Char#
instance CReturnable Char
instance CCallable Int
+instance CCallable Int#
instance CReturnable Int
-- DsCCall knows how to pass strings...
instance CCallable [Char]
instance CCallable Float
+instance CCallable Float#
instance CReturnable Float
instance CCallable Double
+instance CCallable Double#
instance CReturnable Double
instance CCallable Addr
+instance CCallable Addr#
instance CReturnable Addr
instance CCallable Word
+instance CCallable Word#
instance CReturnable Word
-- Is this right?
instance CCallable (MutableByteArray s ix)
+instance CCallable (MutableByteArray# s)
instance CCallable (ByteArray ix)
+instance CCallable ByteArray#
instance CReturnable () -- Why, exactly?
\end{code}
\begin{code}
data ForeignObj = ForeignObj ForeignObj#
instance CCallable ForeignObj
+instance CCallable ForeignObj#
eqForeignObj :: ForeignObj -> ForeignObj -> Bool
makeForeignObj :: Addr -> Addr -> PrimIO ForeignObj
#ifndef __PARALLEL_HASKELL__
data StablePtr a = StablePtr (StablePtr# a)
instance CCallable (StablePtr a)
+instance CCallable (StablePtr# a)
instance CReturnable (StablePtr a)
-- Nota Bene: it is important {\em not\/} to inline calls to
Glorious hacking (all the hard work) by Bryan O'Sullivan.
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PackedString (
packString, -- :: [Char] -> PackedString
packCBytesST, unpackCString
) where
-import Prelude ()
-import IOBase ( error ) {-# SOURCE #-}
+import {#- SOURCE #-} IOBase ( error )
import Ix
import PrelList
import STBase
\section[module_ST]{The State Transformer Monad, @ST@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module ST where
-import Prelude ()
import IOBase ( error ) -- [Source not needed]
import ArrBase
import STBase
\section[Array]{Module @Array@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module Array (
module Ix, -- export all of Ix
Array, -- Array type abstractly
accumArray, (//), accum, amap, ixmap
) where
-import Prelude ()
import Ix
import PrelList
import PrelRead
\section[Char]{Module @Char@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module Char (
isAscii, isControl, isPrint, isSpace, isUpper, isLower,
isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum, toUpper, toLower
) where
-import Prelude ()
import PrelBase
\end{code}
\section[IO]{Module @IO@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module IO (
Handle, HandlePosn,
ioeGetHandle, ioeGetFileName
) where
-import Prelude ()
import Ix
import STBase
import IOBase
\section[Ix]{Module @Ix@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module Ix (
Ix(range, index, inRange)
) where
-import Prelude ()
-import IOBase ( error ) {-# SOURCE #-}
+import {#- SOURCE #-} IOBase ( error )
import PrelNum
import PrelTup
import PrelBase
union, intersect
) where
-import Prelude
\end{code}
%*********************************************************
\section[Maybe]{Module @Maybe@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module Maybe(
Maybe(..),
the, exists, theExists, maybe, fromMaybe, listToMaybe, maybeToList,
findMaybe, catMaybes, mapMaybe, joinMaybe, unfoldr
) where
-import Prelude ()
import IOBase ( error )
import Monad ( filter )
import PrelList
\section[Monad]{Module @Monad@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module Monad (
Functor(..), Monad(..), MonadZero(..), MonadPlus(..),
liftM, liftM2, liftM3, liftM4, liftM5
) where
-import Prelude ()
import PrelList
import PrelTup
import PrelBase
Standard functions on rational numbers
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module Ratio (
Ratio, Rational, (%), numerator, denominator, approxRational
) where
-import Prelude ()
import PrelNum
\end{code}
DEBUG_PR_MARKED;
JUMP_MARK_RETURN;
} else {
- INIT_MARK_NODE("MUT ", MUTUPLE_CLOSURE_NoPTRS(Mark));
- INIT_MSTACK(MUTUPLE_CLOSURE_PTR);
+ INIT_MARK_NODE("MUT ", MUTUPLE_CLOSURE_NoPTRS(Mark));
+ if (MUTUPLE_CLOSURE_NoPTRS(Mark) > 0) {
+ INIT_MSTACK(MUTUPLE_CLOSURE_PTR);
+ } else {
+ JUMP_MARK;
+ }
}
FUNEND;
}
projects / ghc-hetmet.git / commitdiff