Comments and formatting to vectoriser

[ghc-hetmet.git] / compiler / vectorise / VectType.hs

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 6e7557e..878dfab 100644 (file)
--- 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
@@ -45,13 +45,16 @@ import Data.List      ( inits, tails, zipWith4, zipWith5 )
 -- ----------------------------------------------------------------------------
 -- Types
 
+-- | Vectorise a type constructor.
 vectTyCon :: TyCon -> VM TyCon
 vectTyCon tc
   | isFunTyCon tc        = builtin closureTyCon
   | isBoxedTupleTyCon tc = return tc
   | isUnLiftedTyCon tc   = return tc
-  | otherwise            = maybeCantVectoriseM "Tycon not vectorised:" (ppr tc)
-                         $ lookupTyCon tc
+  | otherwise            
+  = maybeCantVectoriseM "Tycon not vectorised: " (ppr tc)
+       $ lookupTyCon tc
+
 
 vectAndLiftType :: Type -> VM (Type, Type)
 vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'
@@ -67,6 +70,7 @@ vectAndLiftType ty
     (tyvars, mono_ty) = splitForAllTys ty
 
 
+-- | Vectorise a type.
 vectType :: Type -> VM Type
 vectType ty | Just ty' <- coreView ty = vectType ty'
 vectType (TyVarTy tv) = return $ TyVarTy tv
@@ -87,6 +91,7 @@ vectType ty = cantVectorise "Can't vectorise type" (ppr ty)
 vectAndBoxType :: Type -> VM Type
 vectAndBoxType ty = vectType ty >>= boxType
 
+-- | Add quantified vars and dictionary parameters to the front of a type.
 abstractType :: [TyVar] -> [Type] -> Type -> Type
 abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts
 
@@ -102,6 +107,7 @@ boxType ty
       case r of
         Just tycon' -> return $ mkTyConApp tycon' []
         Nothing     -> return ty
+
 boxType ty = return ty
 
 -- ----------------------------------------------------------------------------
@@ -109,14 +115,21 @@ boxType ty = return ty
 
 type TyConGroup = ([TyCon], UniqSet TyCon)
 
+-- | Vectorise a type environment.
+--   The type environment contains all the type things defined in a module.
 vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
 vectTypeEnv env
   = do
       cs <- readGEnv $ mk_map . global_tycons
+
+      -- Split the list of TyCons into the ones we have to vectorise vs the
+      -- ones we can pass through unchanged. We also pass through algebraic 
+      -- types that use non Haskell98 features, as we don't handle those.
       let (conv_tcs, keep_tcs) = classifyTyCons cs groups
           keep_dcs             = concatMap tyConDataCons keep_tcs
       zipWithM_ defTyCon   keep_tcs keep_tcs
       zipWithM_ defDataCon keep_dcs keep_dcs
+
       new_tcs <- vectTyConDecls conv_tcs
 
       let orig_tcs = keep_tcs ++ conv_tcs
@@ -151,6 +164,7 @@ vectTypeEnv env
     mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]
 
 
+-- | Vectorise some (possibly recursively defined) type constructors.
 vectTyConDecls :: [TyCon] -> VM [TyCon]
 vectTyConDecls tcs = fixV $ \tcs' ->
   do
@@ -202,7 +216,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 +707,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 +803,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 +816,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 +844,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
 
@@ -847,8 +862,8 @@ paMethods = [("dictPRepr",    buildPRDict),
              ("fromArrPRepr", buildFromArrPRepr)]
 
 -- | Split the given tycons into two sets depending on whether they have to be
--- converted (first list) or not (second list). The first argument contains
--- information about the conversion status of external tycons:
+--   converted (first list) or not (second list). The first argument contains
+--   information about the conversion status of external tycons:
 --
 --   * tycons which have converted versions are mapped to True
 --   * tycons which are not changed by vectorisation are mapped to False