#include "HsVersions.h"
-import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
+import CoreUtils( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
-import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
- isUnLiftedType, isUnboxedTupleType, repType,
- uaUTy, usOnce, usMany, eqUsage, seqType )
+import Type ( Type, applyTy, splitFunTy_maybe,
+ isUnLiftedType, isUnboxedTupleType, repType, seqType )
import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
import PrimOp ( PrimOp(..) )
import Var ( Var, Id, setVarUnique )
import VarEnv
import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
- hasNoBinding, idNewStrictness,
+ isLocalId, hasNoBinding, idNewStrictness,
isDataConId_maybe, idUnfolding
)
import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
-import Unique ( mkBuiltinUnique )
-import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNotTopLevel,
+import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
import UniqSupply
import OrdList
import ErrUtils
import CmdLineOpts
+import Util ( listLengthCmp )
import Outputable
\end{code}
4. Ensure that lambdas only occur as the RHS of a binding
(The code generator can't deal with anything else.)
-5. Do the seq/par munging. See notes with mkCase below.
+5. [Not any more; nuked Jun 2002] Do the seq/par munging.
+
+6. Clone all local Ids.
+ This means that all such Ids are unique, rather than the
+ weaker guarantee of no clashes which the simplifier provides.
+ And that is what the code generator needs.
+
+ We don't clone TyVars. The code gen doesn't need that,
+ and doing so would be tiresome because then we'd need
+ to substitute in types.
-6. Clone all local Ids. This means that Tidy Core has the property
- that all Ids are unique, rather than the weaker guarantee of
- no clashes which the simplifier provides.
7. Give each dynamic CCall occurrence a fresh unique; this is
rather like the cloning step above.
-- The etaExpand is so that the manifest arity of the
-- binding matches its claimed arity, which is an
-- invariant of top level bindings going into the code gen
- where
- tmpl_uniqs = map mkBuiltinUnique [1..]
get_unfolding id -- See notes above
| Just data_con <- isDataConId_maybe id = Var id -- The ice is thin here, but it works
returnUs (floats, Note other_note expr')
corePrepExprFloat env expr@(Lam _ _)
- = corePrepAnExpr env body `thenUs` \ body' ->
- returnUs (nilOL, mkLams bndrs body')
+ = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
+ corePrepAnExpr env' body `thenUs` \ body' ->
+ returnUs (nilOL, mkLams bndrs' body')
where
(bndrs,body) = collectBinders expr
= corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
mapUs (sat_alt env') alts `thenUs` \ alts' ->
- returnUs (floats, mkCase scrut' bndr' alts')
+ returnUs (floats, Case scrut' bndr' alts')
where
sat_alt env (con, bs, rhs)
= cloneBndrs env bs `thenUs` \ (env', bs') ->
where
stricts = case idNewStrictness v of
StrictSig (DmdType _ demands _)
- | depth >= length demands -> demands
- | otherwise -> []
+ | listLengthCmp demands depth /= GT -> demands
+ -- length demands <= depth
+ | otherwise -> []
-- If depth < length demands, then we have too few args to
-- satisfy strictness info so we have to ignore all the
-- strictness info, e.g. + (error "urk")
-> UniqSM (OrdList FloatingBind)
mkLocalNonRec bndr dem floats rhs
- | isUnLiftedType (idType bndr) || isStrict dem
- -- It's a strict let, or the binder is unlifted,
- -- so we definitely float all the bindings
+ | isUnLiftedType (idType bndr)
+ -- If this is an unlifted binding, we always make a case for it.
= ASSERT( not (isUnboxedTupleType (idType bndr)) )
- let -- Don't make a case for a value binding,
+ let
+ float = FloatCase bndr rhs (exprOkForSpeculation rhs)
+ in
+ returnUs (floats `snocOL` float)
+
+ | isStrict dem
+ -- It's a strict let so we definitely float all the bindings
+ = let -- Don't make a case for a value binding,
-- even if it's strict. Otherwise we get
-- case (\x -> e) of ...!
float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
| otherwise = deLam body `thenUs` \ body' ->
returnUs (foldrOL mk_bind body' binds)
where
- mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
+ mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
etaExpandRhs bndr rhs
-- -----------------------------------------------------------------------------
--- Do the seq and par transformation
--- -----------------------------------------------------------------------------
-
-Here we do two pre-codegen transformations:
-
-1. case seq# a of {
- 0 -> seqError ...
- DEFAULT -> rhs }
- ==>
- case a of { DEFAULT -> rhs }
-
-
-2. case par# a of {
- 0 -> parError ...
- DEFAULT -> rhs }
- ==>
- case par# a of {
- DEFAULT -> rhs }
-
-NB: seq# :: a -> Int# -- Evaluate value and return anything
- par# :: a -> Int# -- Spark value and return anything
-
-These transformations can't be done earlier, or else we might
-think that the expression was strict in the variables in which
-rhs is strict --- but that would defeat the purpose of seq and par.
-
-
-\begin{code}
-mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
- -- DEFAULT alt is always first
- = case isPrimOpId_maybe fn of
- Just ParOp -> Case scrut bndr [deflt_alt]
- Just SeqOp -> Case arg new_bndr [deflt_alt]
- other -> Case scrut bndr alts
- where
- -- The binder shouldn't be used in the expression!
- new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
- setIdType bndr (exprType arg)
- -- NB: SeqOp :: forall a. a -> Int#
- -- So bndr has type Int#
- -- But now we are going to scrutinise the SeqOp's argument directly,
- -- so we must change the type of the case binder to match that
- -- of the argument expression e.
-
-mkCase scrut bndr alts = Case scrut bndr alts
-\end{code}
-
-
--- -----------------------------------------------------------------------------
-- Demands
-- -----------------------------------------------------------------------------
mkDem strict once = RhsDemand (isStrictDmd strict) once
mkDemTy :: Demand -> Type -> RhsDemand
-mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
-
-isOnceTy :: Type -> Bool
-isOnceTy ty
- =
-#ifdef USMANY
- opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
-#endif
- once
- where
- u = uaUTy ty
- once | u `eqUsage` usOnce = True
- | u `eqUsage` usMany = False
- | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
+mkDemTy strict ty = RhsDemand (isStrictDmd strict)
+ False {- For now -}
bdrDem :: Id -> RhsDemand
-bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
+bdrDem id = mkDem (idNewDemandInfo id)
+ False {- For now -}
safeDem, onceDem :: RhsDemand
safeDem = RhsDemand False False -- always safe to use this
cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
cloneBndr env bndr
- | isGlobalId bndr -- Top level things, which we don't want
- = returnUs (env, bndr) -- to clone, have become GlobalIds by now
-
- | otherwise
+ | isLocalId bndr
= getUniqueUs `thenUs` \ uniq ->
let
bndr' = setVarUnique bndr uniq
in
returnUs (extendVarEnv env bndr bndr', bndr')
+ | otherwise -- Top level things, which we don't want
+ -- to clone, have become GlobalIds by now
+ -- And we don't clone tyvars
+ = returnUs (env, bndr)
+
+
------------------------------------------------------------------------------
-- Cloning ccall Ids; each must have a unique name,
-- to give the code generator a handle to hang it on
newVar ty
= seqType ty `seq`
getUniqueUs `thenUs` \ uniq ->
- returnUs (mkSysLocal SLIT("sat") uniq ty)
+ returnUs (mkSysLocal FSLIT("sat") uniq ty)
\end{code}
projects / ghc-hetmet.git / blobdiff