X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=37022cfc1da0910935a79dacb9fee9d03e61e1f6;hb=8c5e145eb7f4e88fc3f2ecf5e509768818ae6c02;hp=6e7557e9e20d9f2214e630a2af2491f137364355;hpb=222415a5b658e737a0a1f2c980c6f80635289f75;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 6e7557e..37022cf 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 InlSat body arity
+                              mkInlineRule body (Just arity)
           defGlobalVar orig_worker vect_worker
           return (vect_worker, body)
       where
@@ -802,16 +802,16 @@ buildPADict vect_tc prepr_tc arr_tc repr
       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
@@ -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 InlSat body (length args)
+                      `setIdUnfolding` mkInlineRule body (Just (length args))
+                      `setInlinePragma` alwaysInlinePragma
           hoistBinding var body
           return var