import TysWiredIn
import PrelRules
import Type
-import TypeRep
import Coercion
import TcType
import CoreUtils ( exprType, mkCoerce )
import Class
import VarSet
import Name
-import OccName
import PrimOp
import ForeignCall
import DataCon
import NewDemand
import CoreSyn
import Unique
-import Maybes
import PrelNames
import BasicTypes hiding ( SuccessFlag(..) )
import Util
-- ...(let w = C x in ...(w p q)...)...
-- we want to see that w is strict in its two arguments
- wrap_unf = mkImplicitUnfolding $ Note InlineMe $
- mkLams wrap_tvs $
+ wrap_unf = mkInlineRule InlSat wrap_rhs (length dict_args + length id_args)
+ wrap_rhs = mkLams wrap_tvs $
mkLams eq_args $
mkLams dict_args $ mkLams id_args $
foldr mk_case con_app
info = noCafIdInfo
`setArityInfo` 1
`setAllStrictnessInfo` Just strict_sig
- `setUnfoldingInfo` (if no_unf then noUnfolding
- else mkImplicitUnfolding rhs)
+ `setSpecInfo` mkSpecInfo [rule]
+ `setInlinePragInfo` neverInlinePragma
+ `setUnfoldingInfo` (if no_unf then noUnfolding
+ else mkImplicitUnfolding rhs)
+ -- Experimental: NOINLINE, so that their rule matches
-- We no longer use 'must-inline' on record selectors. They'll
-- inline like crazy if they scrutinise a constructor
+ n_ty_args = length tyvars
+
+ -- This is the built-in rule that goes
+ -- op (dfT d1 d2) ---> opT d1 d2
+ rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS`
+ occNameFS (getOccName name)
+ , ru_fn = name
+ , ru_nargs = n_ty_args + 1
+ , ru_try = dictSelRule index n_ty_args }
+
-- The strictness signature is of the form U(AAAVAAAA) -> T
-- where the V depends on which item we are selecting
-- It's worth giving one, so that absence info etc is generated
tyvars = dataConUnivTyVars data_con
arg_tys = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con
eq_theta = dataConEqTheta data_con
- the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
+ index = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` [0..]) name
+ the_arg_id = arg_ids !! index
pred = mkClassPred clas (mkTyVarTys tyvars)
dict_id = mkTemplateLocal 1 $ mkPredTy pred
rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
| otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
[(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
+
+dictSelRule :: Int -> Arity -> [CoreExpr] -> Maybe CoreExpr
+-- Oh, very clever
+-- op_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
+-- op_i t1..tk (D t1..tk op1 ... opm) = opi
+--
+-- NB: the data constructor has the same number of type args as the class op
+
+dictSelRule index n_ty_args args
+ | (dict_arg : _) <- drop n_ty_args args
+ , Just (_, _, val_args) <- exprIsConApp_maybe dict_arg
+ = Just (val_args !! index)
+ | otherwise
+ = Nothing
\end{code}
-> Id
mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
- = mkExportedLocalVar DFunId dfun_name dfun_ty vanillaIdInfo
+ = mkExportedLocalVar (DFunId is_nt) dfun_name dfun_ty vanillaIdInfo
where
+ is_nt = isNewTyCon (classTyCon clas)
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
\end{code}
mkCompulsoryUnfolding (Lit nullAddrLit)
------------------------------------------------
-seqId :: Id
--- 'seq' is very special. See notes with
--- See DsUtils.lhs Note [Desugaring seq (1)] and
--- Note [Desugaring seq (2)] and
--- Fixity is set in LoadIface.ghcPrimIface
+seqId :: Id -- See Note [seqId magic]
seqId = pcMiscPrelId seqName ty info
where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
\end{code}
+Note [seqId magic]
+~~~~~~~~~~~~~~~~~~
+'GHC.Prim.seq' is special in several ways.
+
+a) Its second arg can have an unboxed type
+ x `seq` (v +# w)
+
+b) Its fixity is set in LoadIface.ghcPrimIface
+
+c) It has quite a bit of desugaring magic.
+ See DsUtils.lhs Note [Desugaring seq (1)] and (2) and (3)
+
+d) There is some special rule handing: Note [RULES for seq]
+
+Note [RULES for seq]
+~~~~~~~~~~~~~~~~~~~~
+Roman found situations where he had
+ case (f n) of _ -> e
+where he knew that f (which was strict in n) would terminate if n did.
+Notice that the result of (f n) is discarded. So it makes sense to
+transform to
+ case n of _ -> e
+
+Rather than attempt some general analysis to support this, I've added
+enough support that you can do this using a rewrite rule:
+
+ RULE "f/seq" forall n. seq (f n) e = seq n e
+
+You write that rule. When GHC sees a case expression that discards
+its result, it mentally transforms it to a call to 'seq' and looks for
+a RULE. (This is done in Simplify.rebuildCase.) As usual, the
+correctness of the rule is up to you.
+
+To make this work, we need to be careful that the magical desugaring
+done in Note [seqId magic] item (c) is *not* done on the LHS of a rule.
+Or rather, we arrange to un-do it, in DsBinds.decomposeRuleLhs.
+
+
Note [lazyId magic]
~~~~~~~~~~~~~~~~~~~
lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
projects / ghc-hetmet.git / blobdiff