#include "HsVersions.h"
import CoreSyn
-import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault )
+import CoreUtils ( exprType, findDefault )
+import CoreArity ( manifestArity )
import StgSyn
import Type
import MonadUtils
import FastString
import Util
+import ForeignCall
+import PrimOp ( PrimCall(..) )
\end{code}
%************************************************************************
coreTopBindsToStg this_pkg env (b:bs)
= (env2, fvs2, b':bs')
where
- -- env accumulates down the list of binds, fvs accumulates upwards
+ -- Notice the mutually-recursive "knot" here:
+ -- env accumulates down the list of binds,
+ -- fvs accumulates upwards
(env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
(env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
-
coreTopBindToStg
:: PackageId
-> IdEnv HowBound
bind = StgNonRec id stg_rhs
in
- ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext (sLit "rhs:")) <+> ppr rhs $$ (ptext (sLit "stg_rhs:"))<+> ppr stg_rhs $$ (ptext (sLit "Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext (sLit "STG:")) <+>(ppr $ stgRhsArity stg_rhs) )
- ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind)
--- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
+ ASSERT2(consistentCafInfo id bind, ppr id )
+ -- NB: previously the assertion printed 'rhs' and 'bind'
+ -- as well as 'id', but that led to a black hole
+ -- where printing the assertion error tripped the
+ -- assertion again!
(env', fvs' `unionFVInfo` body_fvs, bind)
coreTopBindToStg this_pkg env body_fvs (Rec pairs)
- = let
- (binders, rhss) = unzip pairs
+ = ASSERT( not (null pairs) )
+ let
+ binders = map fst pairs
extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
| (b, rhs) <- pairs ]
bind = StgRec (zip binders stg_rhss)
in
- ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
(env', fvs' `unionFVInfo` body_fvs, bind)
+
-- Assertion helper: this checks that the CafInfo on the Id matches
-- what CoreToStg has figured out about the binding's SRT. The
-- CafInfo will be exact in all cases except when CorePrep has
-- floated out a binding, in which case it will be approximate.
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
consistentCafInfo id bind
- | occNameFS (nameOccName (idName id)) == fsLit "sat"
- = safe
- | otherwise
- = WARN (not exact, ppr id) safe
+ = WARN( not (exact || is_sat_thing) , ppr id )
+ safe
where
- safe = id_marked_caffy || not binding_is_caffy
- exact = id_marked_caffy == binding_is_caffy
- id_marked_caffy = mayHaveCafRefs (idCafInfo id)
- binding_is_caffy = stgBindHasCafRefs bind
+ safe = id_marked_caffy || not binding_is_caffy
+ exact = id_marked_caffy == binding_is_caffy
+ id_marked_caffy = mayHaveCafRefs (idCafInfo id)
+ binding_is_caffy = stgBindHasCafRefs bind
+ is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
\end{code}
\begin{code}
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
-coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs) = do
- (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
- lv_info <- freeVarsToLiveVars rhs_fvs
- return (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
+coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
+ = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
+ ; lv_info <- freeVarsToLiveVars rhs_fvs
+
+ ; let stg_rhs = mkTopStgRhs this_pkg rhs_fvs (mkSRT lv_info) bndr_info new_rhs
+ stg_arity = stgRhsArity stg_rhs
+ ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
+ rhs_fvs) }
where
bndr_info = lookupFVInfo scope_fv_info bndr
- is_static = rhsIsStatic this_pkg rhs
-mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
- -> StgRhs
-
-mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
- = ASSERT( is_static )
- StgRhsClosure noCCS binder_info
+ -- It's vital that the arity on a top-level Id matches
+ -- the arity of the generated STG binding, else an importing
+ -- module will use the wrong calling convention
+ -- (Trac #2844 was an example where this happened)
+ -- NB1: we can't move the assertion further out without
+ -- blocking the "knot" tied in coreTopBindsToStg
+ -- NB2: the arity check is only needed for Ids with External
+ -- Names, because they are externally visible. The CorePrep
+ -- pass introduces "sat" things with Local Names and does
+ -- not bother to set their Arity info, so don't fail for those
+ arity_ok stg_arity
+ | isExternalName (idName bndr) = id_arity == stg_arity
+ | otherwise = True
+ id_arity = idArity bndr
+ mk_arity_msg stg_arity
+ = vcat [ppr bndr,
+ ptext (sLit "Id arity:") <+> ppr id_arity,
+ ptext (sLit "STG arity:") <+> ppr stg_arity]
+
+mkTopStgRhs :: PackageId -> FreeVarsInfo
+ -> SRT -> StgBinderInfo -> StgExpr
+ -> StgRhs
+
+mkTopStgRhs _ rhs_fvs srt binder_info (StgLam _ bndrs body)
+ = StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
srt
bndrs body
-
-mkTopStgRhs is_static _ _ _ (StgConApp con args)
- | is_static -- StgConApps can be updatable (see isCrossDllConApp)
+
+mkTopStgRhs this_pkg _ _ _ (StgConApp con args)
+ | not (isDllConApp this_pkg con args) -- Dynamic StgConApps are updatable
= StgRhsCon noCCS con args
-mkTopStgRhs is_static rhs_fvs srt binder_info rhs
- = ASSERT2( not is_static, ppr rhs )
- StgRhsClosure noCCS binder_info
+mkTopStgRhs _ rhs_fvs srt binder_info rhs
+ = StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
Updatable
srt
| isUnLiftedTyCon tc -> PrimAlt tc
| isHiBootTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
- | otherwise -> ASSERT( _is_poly_alt_tycon tc )
+ | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
PolyAlt
Nothing -> PolyAlt
_is_poly_alt_tycon tc
= isFunTyCon tc
|| isPrimTyCon tc -- "Any" is lifted but primitive
- || isOpenTyCon tc -- Type family; e.g. arising from strict
+ || isFamilyTyCon tc -- Type family; e.g. arising from strict
-- function application where argument has a
-- type-family type
-- two regardless.
res_ty = exprType (mkApps (Var f) args)
- app = case globalIdDetails f of
+ app = case idDetails f of
DataConWorkId dc | saturated -> StgConApp dc args'
+
+ -- Some primitive operator that might be implemented as a library call.
PrimOpId op -> ASSERT( saturated )
StgOpApp (StgPrimOp op) args' res_ty
+
+ -- A call to some primitive Cmm function.
+ FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
+ -> ASSERT( saturated )
+ StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
+
+ -- A regular foreign call.
FCallId call -> ASSERT( saturated )
StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+
TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
_other -> StgApp f args'
go (Note (SCC _) _) _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
go (Cast e _) as = go e as
go (Note _ e) as = go e as
+ go (Lam b e) as
+ | isTyCoVar b = go e as -- Note [Collect args]
go _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
\end{code}
+Note [Collect args]
+~~~~~~~~~~~~~~~~~~~
+This big-lambda case occurred following a rather obscure eta expansion.
+It all seems a bit yukky to me.
+
\begin{code}
stgArity :: Id -> HowBound -> Arity
stgArity _ (LetBound _ arity) = arity