X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=37d65db91e29be98a950ed0499a13b8494ed66ac;hp=16ac82adcaac488255748067c818e483676b6d77;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=c86161c5cf11de77e911fcb9e1e2bd1f8bd80b42 diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 16ac82a..37d65db 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -23,8 +23,8 @@ import FamInstEnv ( FamInst, mkLocalFamInst ) import OccName import Id import MkId -import BasicTypes ( StrictnessMark(..), boolToRecFlag, - dfunInlinePragma ) +import BasicTypes ( HsBang(..), boolToRecFlag, + alwaysInlinePragma, dfunInlinePragma ) import Var ( Var, TyVar, varType ) import Name ( Name, getOccName ) import NameEnv @@ -202,7 +202,7 @@ vectDataCon dc 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 @@ -693,7 +693,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr liftDs $ buildDataCon dc_name False -- not infix - (map (const NotMarkedStrict) comp_tys) + (map (const HsNoBang) comp_tys) [] -- no field labels tvs [] -- no existentials @@ -789,7 +789,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc 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 @@ -830,7 +830,8 @@ buildPADict vect_tc prepr_tc arr_tc repr 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