import OccName
import Id
import MkId
-import BasicTypes ( StrictnessMark(..), boolToRecFlag,
+import BasicTypes ( HsBang(..), boolToRecFlag,
alwaysInlinePragma, dfunInlinePragma )
import Var ( Var, TyVar, varType )
import Name ( Name, getOccName )
liftDs $ buildDataCon name'
False -- not infix
- (map (const NotMarkedStrict) arg_tys)
+ (map (const HsNoBang) arg_tys)
[] -- no labelled fields
univ_tvs
[] -- no existential tvs for now
liftDs $ buildDataCon dc_name
False -- not infix
- (map (const NotMarkedStrict) comp_tys)
+ (map (const HsNoBang) comp_tys)
[] -- no field labels
tvs
[] -- no existentials
raw_worker <- cloneId mkVectOcc orig_worker (exprType body)
let vect_worker = raw_worker `setIdUnfolding`
- mkInlineRule needSaturated body arity
+ mkInlineRule body (Just arity)
defGlobalVar orig_worker vect_worker
return (vect_worker, body)
where
method_ids <- mapM (method args) paMethods
pa_tc <- builtin paTyCon
- pa_con <- builtin paDataCon
+ pa_dc <- builtin paDataCon
let dict = mkLams (tvs ++ args)
- $ mkConApp pa_con
+ $ mkConApp pa_dc
$ Type inst_ty : map (method_call args) method_ids
dfun_ty = mkForAllTys tvs
$ mkFunTys (map varType args) (mkTyConApp pa_tc [inst_ty])
raw_dfun <- newExportedVar dfun_name dfun_ty
- let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding pa_con method_ids
+ let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding dfun_ty (map Var method_ids)
`setInlinePragma` dfunInlinePragma
hoistBinding dfun dict
let body = mkLams (tvs ++ args) expr
raw_var <- newExportedVar (method_name name) (exprType body)
let var = raw_var
- `setIdUnfolding` mkInlineRule needSaturated body (length args)
+ `setIdUnfolding` mkInlineRule body (Just (length args))
`setInlinePragma` alwaysInlinePragma
hoistBinding var body
return var