compiler/vectorise/VectType.hs

   1 module VectType ( vectTyCon, vectType, vectTypeEnv,
   2                    PAInstance, buildPADict )
   3 where
   4
   5 #include "HsVersions.h"
   6
   7 import VectMonad
   8 import VectUtils
   9 import VectCore
  10
  11 import HscTypes          ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
  12 import CoreSyn
  13 import CoreUtils
  14 import BuildTyCl
  15 import DataCon
  16 import TyCon
  17 import Type
  18 import TypeRep
  19 import Coercion
  20 import FamInstEnv        ( FamInst, mkLocalFamInst )
  21 import InstEnv           ( Instance, mkLocalInstance, instanceDFunId )
  22 import OccName
  23 import MkId
  24 import BasicTypes        ( StrictnessMark(..), OverlapFlag(..), boolToRecFlag )
  25 import Var               ( Var )
  26 import Id                ( mkWildId )
  27 import Name              ( Name, getOccName )
  28 import NameEnv
  29 import TysWiredIn        ( unitTy, intTy, intDataCon )
  30 import TysPrim           ( intPrimTy )
  31
  32 import Unique
  33 import UniqFM
  34 import UniqSet
  35 import Digraph           ( SCC(..), stronglyConnComp )
  36
  37 import Outputable
  38
  39 import Control.Monad  ( liftM, liftM2, zipWithM, zipWithM_ )
  40 import Data.List      ( inits, tails, zipWith4 )
  41
  42 -- ----------------------------------------------------------------------------
  43 -- Types
  44
  45 vectTyCon :: TyCon -> VM TyCon
  46 vectTyCon tc
  47   | isFunTyCon tc        = builtin closureTyCon
  48   | isBoxedTupleTyCon tc = return tc
  49   | isUnLiftedTyCon tc   = return tc
  50   | otherwise = do
  51                   r <- lookupTyCon tc
  52                   case r of
  53                     Just tc' -> return tc'
  54
  55                     -- FIXME: just for now
  56                     Nothing  -> pprTrace "ccTyCon:" (ppr tc) $ return tc
  57
  58 vectType :: Type -> VM Type
  59 vectType ty | Just ty' <- coreView ty = vectType ty'
  60 vectType (TyVarTy tv) = return $ TyVarTy tv
  61 vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
  62 vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
  63 vectType (FunTy ty1 ty2)   = liftM2 TyConApp (builtin closureTyCon)
  64                                              (mapM vectType [ty1,ty2])
  65 vectType ty@(ForAllTy _ _)
  66   = do
  67       mdicts   <- mapM paDictArgType tyvars
  68       mono_ty' <- vectType mono_ty
  69       return $ tyvars `mkForAllTys` ([dict | Just dict <- mdicts] `mkFunTys` mono_ty')
  70   where
  71     (tyvars, mono_ty) = splitForAllTys ty
  72
  73 vectType ty = pprPanic "vectType:" (ppr ty)
  74
  75 -- ----------------------------------------------------------------------------
  76 -- Type definitions
  77
  78 type TyConGroup = ([TyCon], UniqSet TyCon)
  79
  80 data PAInstance = PAInstance {
  81                     painstDFun      :: Var
  82                   , painstOrigTyCon :: TyCon
  83                   , painstVectTyCon :: TyCon
  84                   , painstArrTyCon  :: TyCon
  85                   }
  86
  87 vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
  88 vectTypeEnv env
  89   = do
  90       cs <- readGEnv $ mk_map . global_tycons
  91       let (conv_tcs, keep_tcs) = classifyTyCons cs groups
  92           keep_dcs             = concatMap tyConDataCons keep_tcs
  93       zipWithM_ defTyCon   keep_tcs keep_tcs
  94       zipWithM_ defDataCon keep_dcs keep_dcs
  95       new_tcs <- vectTyConDecls conv_tcs
  96
  97       let orig_tcs = keep_tcs ++ conv_tcs
  98           vect_tcs  = keep_tcs ++ new_tcs
  99
 100       repr_tcs <- zipWithM buildPReprTyCon   orig_tcs vect_tcs
 101       parr_tcs <- zipWithM buildPArrayTyCon orig_tcs vect_tcs
 102       dfuns    <- mapM mkPADFun vect_tcs
 103       defTyConPAs (zip vect_tcs dfuns)
 104       binds    <- sequence (zipWith4 buildTyConBindings orig_tcs vect_tcs parr_tcs dfuns)
 105
 106       let all_new_tcs = new_tcs ++ repr_tcs ++ parr_tcs
 107
 108       let new_env = extendTypeEnvList env
 109                        (map ATyCon all_new_tcs
 110                         ++ [ADataCon dc | tc <- all_new_tcs
 111                                         , dc <- tyConDataCons tc])
 112
 113       return (new_env, map mkLocalFamInst (repr_tcs ++ parr_tcs), concat binds)
 114   where
 115     tycons = typeEnvTyCons env
 116     groups = tyConGroups tycons
 117
 118     mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]
 119
 120     keep_tc tc = let dcs = tyConDataCons tc
 121                  in
 122                  defTyCon tc tc >> zipWithM_ defDataCon dcs dcs
 123
 124
 125 vectTyConDecls :: [TyCon] -> VM [TyCon]
 126 vectTyConDecls tcs = fixV $ \tcs' ->
 127   do
 128     mapM_ (uncurry defTyCon) (lazy_zip tcs tcs')
 129     mapM vectTyConDecl tcs
 130   where
 131     lazy_zip [] _ = []
 132     lazy_zip (x:xs) ~(y:ys) = (x,y) : lazy_zip xs ys
 133
 134 vectTyConDecl :: TyCon -> VM TyCon
 135 vectTyConDecl tc
 136   = do
 137       name' <- cloneName mkVectTyConOcc name
 138       rhs'  <- vectAlgTyConRhs (algTyConRhs tc)
 139
 140       liftDs $ buildAlgTyCon name'
 141                              tyvars
 142                              []           -- no stupid theta
 143                              rhs'
 144                              rec_flag     -- FIXME: is this ok?
 145                              False        -- FIXME: no generics
 146                              False        -- not GADT syntax
 147                              Nothing      -- not a family instance
 148   where
 149     name   = tyConName tc
 150     tyvars = tyConTyVars tc
 151     rec_flag = boolToRecFlag (isRecursiveTyCon tc)
 152
 153 vectAlgTyConRhs :: AlgTyConRhs -> VM AlgTyConRhs
 154 vectAlgTyConRhs (DataTyCon { data_cons = data_cons
 155                            , is_enum   = is_enum
 156                            })
 157   = do
 158       data_cons' <- mapM vectDataCon data_cons
 159       zipWithM_ defDataCon data_cons data_cons'
 160       return $ DataTyCon { data_cons = data_cons'
 161                          , is_enum   = is_enum
 162                          }
 163
 164 vectDataCon :: DataCon -> VM DataCon
 165 vectDataCon dc
 166   | not . null $ dataConExTyVars dc = pprPanic "vectDataCon: existentials" (ppr dc)
 167   | not . null $ dataConEqSpec   dc = pprPanic "vectDataCon: eq spec" (ppr dc)
 168   | otherwise
 169   = do
 170       name'    <- cloneName mkVectDataConOcc name
 171       tycon'   <- vectTyCon tycon
 172       arg_tys  <- mapM vectType rep_arg_tys
 173
 174       liftDs $ buildDataCon name'
 175                             False           -- not infix
 176                             (map (const NotMarkedStrict) arg_tys)
 177                             []              -- no labelled fields
 178                             univ_tvs
 179                             []              -- no existential tvs for now
 180                             []              -- no eq spec for now
 181                             []              -- no context
 182                             arg_tys
 183                             tycon'
 184   where
 185     name        = dataConName dc
 186     univ_tvs    = dataConUnivTyVars dc
 187     rep_arg_tys = dataConRepArgTys dc
 188     tycon       = dataConTyCon dc
 189
 190 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
 191 mk_fam_inst fam_tc arg_tc
 192   = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
 193
 194 buildPReprTyCon :: TyCon -> TyCon -> VM TyCon
 195 buildPReprTyCon orig_tc vect_tc
 196   = do
 197       name     <- cloneName mkPReprTyConOcc (tyConName orig_tc)
 198       rhs_ty   <- buildPReprRhsTy vect_tc
 199       prepr_tc <- builtin preprTyCon
 200       liftDs $ buildSynTyCon name
 201                              tyvars
 202                              (SynonymTyCon rhs_ty)
 203                              (Just $ mk_fam_inst prepr_tc vect_tc)
 204   where
 205     tyvars = tyConTyVars vect_tc
 206
 207 buildPReprRhsTy :: TyCon -> VM Type
 208 buildPReprRhsTy = buildPReprTy . map dataConRepArgTys . tyConDataCons
 209
 210 buildPReprTy :: [[Type]] -> VM Type
 211 buildPReprTy tys = mkPlusTypes unitTy
 212                =<< mapM (mkCrossTypes unitTy)
 213                =<< mapM (mapM mkEmbedType) tys
 214
 215 buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
 216 buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
 217   do
 218     name'  <- cloneName mkPArrayTyConOcc orig_name
 219     rhs    <- buildPArrayTyConRhs orig_name vect_tc repr_tc
 220     parray <- builtin parrayTyCon
 221
 222     liftDs $ buildAlgTyCon name'
 223                            tyvars
 224                            []          -- no stupid theta
 225                            rhs
 226                            rec_flag    -- FIXME: is this ok?
 227                            False       -- FIXME: no generics
 228                            False       -- not GADT syntax
 229                            (Just $ mk_fam_inst parray vect_tc)
 230   where
 231     orig_name = tyConName orig_tc
 232     tyvars = tyConTyVars vect_tc
 233     rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
 234
 235
 236 buildPArrayTyConRhs :: Name -> TyCon -> TyCon -> VM AlgTyConRhs
 237 buildPArrayTyConRhs orig_name vect_tc repr_tc
 238   = do
 239       data_con <- buildPArrayDataCon orig_name vect_tc repr_tc
 240       return $ DataTyCon { data_cons = [data_con], is_enum = False }
 241
 242 buildPArrayDataCon :: Name -> TyCon -> TyCon -> VM DataCon
 243 buildPArrayDataCon orig_name vect_tc repr_tc
 244   = do
 245       dc_name  <- cloneName mkPArrayDataConOcc orig_name
 246       shape    <- tyConShape vect_tc
 247       repr_tys <- mapM mkPArrayType types
 248
 249       liftDs $ buildDataCon dc_name
 250                             False                  -- not infix
 251                             (shapeStrictness shape ++ map (const NotMarkedStrict) repr_tys)
 252                             []                     -- no field labels
 253                             (tyConTyVars vect_tc)
 254                             []                     -- no existentials
 255                             []                     -- no eq spec
 256                             []                     -- no context
 257                             (shapeReprTys shape ++ repr_tys)
 258                             repr_tc
 259   where
 260     types = [ty | dc <- tyConDataCons vect_tc
 261                 , ty <- dataConRepArgTys dc]
 262
 263 mkPADFun :: TyCon -> VM Var
 264 mkPADFun vect_tc
 265   = newExportedVar (mkPADFunOcc $ getOccName vect_tc) =<< paDFunType vect_tc
 266
 267 data Shape = Shape {
 268                shapeReprTys    :: [Type]
 269              , shapeStrictness :: [StrictnessMark]
 270              , shapeLength     :: [CoreExpr] -> VM CoreExpr
 271              , shapeReplicate  :: CoreExpr -> CoreExpr -> VM [CoreExpr]
 272              }
 273
 274 tyConShape :: TyCon -> VM Shape
 275 tyConShape vect_tc
 276   | isProductTyCon vect_tc
 277   = return $ Shape {
 278                 shapeReprTys    = [intPrimTy]
 279               , shapeStrictness = [NotMarkedStrict]
 280               , shapeLength     = \[len] -> return len
 281               , shapeReplicate  = \len _ -> return [len]
 282               }
 283
 284   | otherwise
 285   = do
 286       repr_ty <- mkPArrayType intTy   -- FIXME: we want to unbox this
 287       return $ Shape {
 288                  shapeReprTys    = [repr_ty]
 289                , shapeStrictness = [MarkedStrict]
 290                , shapeLength     = \[sel] -> lengthPA sel
 291                , shapeReplicate  = \len n -> do
 292                                                e <- replicatePA len n
 293                                                return [e]
 294                }
 295
 296 buildTyConBindings :: TyCon -> TyCon -> TyCon -> Var -> VM [(Var, CoreExpr)]
 297 buildTyConBindings orig_tc vect_tc arr_tc dfun
 298   = do
 299       shape <- tyConShape vect_tc
 300       sequence_ (zipWith4 (vectDataConWorker shape vect_tc arr_tc arr_dc)
 301                           orig_dcs
 302                           vect_dcs
 303                           (inits repr_tys)
 304                           (tails repr_tys))
 305       dict <- buildPADict shape vect_tc arr_tc dfun
 306       binds <- takeHoisted
 307       return $ (dfun, dict) : binds
 308   where
 309     orig_dcs = tyConDataCons orig_tc
 310     vect_dcs = tyConDataCons vect_tc
 311     [arr_dc] = tyConDataCons arr_tc
 312
 313     repr_tys = map dataConRepArgTys vect_dcs
 314
 315 vectDataConWorker :: Shape -> TyCon -> TyCon -> DataCon
 316                   -> DataCon -> DataCon -> [[Type]] -> [[Type]]
 317                   -> VM ()
 318 vectDataConWorker shape vect_tc arr_tc arr_dc orig_dc vect_dc pre (dc_tys : post)
 319   = do
 320       clo <- closedV
 321            . inBind orig_worker
 322            . polyAbstract tvs $ \abstract ->
 323              liftM (abstract . vectorised)
 324            $ buildClosures tvs [] dc_tys res_ty (liftM2 (,) mk_vect mk_lift)
 325
 326       worker <- cloneId mkVectOcc orig_worker (exprType clo)
 327       hoistBinding worker clo
 328       defGlobalVar orig_worker worker
 329       return ()
 330   where
 331     tvs     = tyConTyVars vect_tc
 332     arg_tys = mkTyVarTys tvs
 333     res_ty  = mkTyConApp vect_tc arg_tys
 334
 335     orig_worker = dataConWorkId orig_dc
 336
 337     mk_vect = return . mkConApp vect_dc $ map Type arg_tys
 338     mk_lift = do
 339                 len     <- newLocalVar FSLIT("n") intPrimTy
 340                 arr_tys <- mapM mkPArrayType dc_tys
 341                 args    <- mapM (newLocalVar FSLIT("xs")) arr_tys
 342                 shapes  <- shapeReplicate shape
 343                                           (Var len)
 344                                           (mkDataConTag vect_dc)
 345
 346                 empty_pre  <- mapM emptyPA (concat pre)
 347                 empty_post <- mapM emptyPA (concat post)
 348
 349                 return . mkLams (len : args)
 350                        . wrapFamInstBody arr_tc arg_tys
 351                        . mkConApp arr_dc
 352                        $ map Type arg_tys ++ shapes
 353                                           ++ empty_pre
 354                                           ++ map Var args
 355                                           ++ empty_post
 356
 357 buildPADict :: Shape -> TyCon -> TyCon -> Var -> VM CoreExpr
 358 buildPADict shape vect_tc arr_tc dfun
 359   = polyAbstract tvs $ \abstract ->
 360     do
 361       meth_binds <- mapM (mk_method shape) paMethods
 362       let meth_exprs = map (Var . fst) meth_binds
 363
 364       pa_dc <- builtin paDataCon
 365       let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs)
 366           body = Let (Rec meth_binds) dict
 367       return . mkInlineMe $ abstract body
 368   where
 369     tvs = tyConTyVars arr_tc
 370     arg_tys = mkTyVarTys tvs
 371
 372     mk_method shape (name, build)
 373       = localV
 374       $ do
 375           body <- build shape vect_tc arr_tc
 376           var  <- newLocalVar name (exprType body)
 377           return (var, mkInlineMe body)
 378
 379 paMethods = [(FSLIT("lengthPA"),    buildLengthPA),
 380              (FSLIT("replicatePA"), buildReplicatePA)]
 381
 382 buildLengthPA :: Shape -> TyCon -> TyCon -> VM CoreExpr
 383 buildLengthPA shape vect_tc arr_tc
 384   = do
 385       parr_ty <- mkPArrayType (mkTyConApp vect_tc arg_tys)
 386       arg    <- newLocalVar FSLIT("xs") parr_ty
 387       shapes <- mapM (newLocalVar FSLIT("sh")) shape_tys
 388       wilds  <- mapM newDummyVar repr_tys
 389       let scrut    = unwrapFamInstScrut arr_tc arg_tys (Var arg)
 390           scrut_ty = exprType scrut
 391
 392       body <- shapeLength shape (map Var shapes)
 393
 394       return . Lam arg
 395              $ Case scrut (mkWildId scrut_ty) intPrimTy
 396                     [(DataAlt repr_dc, shapes ++ wilds, body)]
 397   where
 398     arg_tys = mkTyVarTys $ tyConTyVars arr_tc
 399     [repr_dc] = tyConDataCons arr_tc
 400
 401     shape_tys = shapeReprTys shape
 402     repr_tys  = drop (length shape_tys) (dataConRepArgTys repr_dc)
 403
 404 -- data T = C0 t1 ... tm
 405 --          ...
 406 --          Ck u1 ... un
 407 --
 408 -- data [:T:] = A ![:Int:] [:t1:] ... [:un:]
 409 --
 410 -- replicatePA :: Int# -> T -> [:T:]
 411 -- replicatePA n# t
 412 --   = let c = case t of
 413 --               C0 _ ... _ -> 0
 414 --               ...
 415 --               Ck _ ... _ -> k
 416 --
 417 --         xs1 = case t of
 418 --                 C0 x1 _ ... _ -> replicatePA @t1 n# x1
 419 --                 _             -> emptyPA @t1
 420 --
 421 --         ...
 422 --
 423 --         ysn = case t of
 424 --                 Ck _ ... _ yn -> replicatePA @un n# yn
 425 --                 _             -> emptyPA @un
 426 --     in
 427 --     A (replicatePA @Int n# c) xs1 ... ysn
 428 --
 429 --
 430
 431 buildReplicatePA :: Shape -> TyCon -> TyCon -> VM CoreExpr
 432 buildReplicatePA shape vect_tc arr_tc
 433   = do
 434       len_var <- newLocalVar FSLIT("n") intPrimTy
 435       val_var <- newLocalVar FSLIT("x") val_ty
 436
 437       let len = Var len_var
 438           val = Var val_var
 439
 440       shape_reprs <- shapeReplicate shape len (ctr_num val)
 441       reprs <- liftM concat $ mapM (mk_comp_arrs len val) vect_dcs
 442
 443       return . mkLams [len_var, val_var]
 444              . wrapFamInstBody arr_tc arg_tys
 445              $ mkConApp arr_dc (map Type arg_tys ++ shape_reprs ++ reprs)
 446   where
 447     arg_tys = mkTyVarTys (tyConTyVars arr_tc)
 448     val_ty  = mkTyConApp vect_tc arg_tys
 449     wild    = mkWildId val_ty
 450     vect_dcs = tyConDataCons vect_tc
 451     [arr_dc] = tyConDataCons arr_tc
 452
 453     ctr_num val = Case val wild intTy (zipWith ctr_num_alt vect_dcs [0..])
 454     ctr_num_alt dc i = (DataAlt dc, map mkWildId (dataConRepArgTys dc),
 455                                     mkConApp intDataCon [mkIntLitInt i])
 456
 457
 458     mk_comp_arrs len val dc = let tys = dataConRepArgTys dc
 459                                   wilds = map mkWildId tys
 460                               in
 461                               sequence (zipWith3 (mk_comp_arr len val dc)
 462                                        tys (inits wilds) (tails wilds))
 463
 464     mk_comp_arr len val dc ty pre (_:post)
 465       = do
 466           var   <- newLocalVar FSLIT("x") ty
 467           rep   <- replicatePA len (Var var)
 468           empty <- emptyPA ty
 469           arr_ty <- mkPArrayType ty
 470
 471           return $ Case val wild arr_ty
 472                      [(DEFAULT, [], empty), (DataAlt dc, pre ++ (var : post), rep)]
 473
 474 -- | Split the given tycons into two sets depending on whether they have to be
 475 -- converted (first list) or not (second list). The first argument contains
 476 -- information about the conversion status of external tycons:
 477 --
 478 --   * tycons which have converted versions are mapped to True
 479 --   * tycons which are not changed by vectorisation are mapped to False
 480 --   * tycons which can't be converted are not elements of the map
 481 --
 482 classifyTyCons :: UniqFM Bool -> [TyConGroup] -> ([TyCon], [TyCon])
 483 classifyTyCons = classify [] []
 484   where
 485     classify conv keep cs [] = (conv, keep)
 486     classify conv keep cs ((tcs, ds) : rs)
 487       | can_convert && must_convert
 488         = classify (tcs ++ conv) keep (cs `addListToUFM` [(tc,True) | tc <- tcs]) rs
 489       | can_convert
 490         = classify conv (tcs ++ keep) (cs `addListToUFM` [(tc,False) | tc <- tcs]) rs
 491       | otherwise
 492         = classify conv keep cs rs
 493       where
 494         refs = ds `delListFromUniqSet` tcs
 495
 496         can_convert  = isNullUFM (refs `minusUFM` cs) && all convertable tcs
 497         must_convert = foldUFM (||) False (intersectUFM_C const cs refs)
 498
 499         convertable tc = isDataTyCon tc && all isVanillaDataCon (tyConDataCons tc)
 500
 501 -- | Compute mutually recursive groups of tycons in topological order
 502 --
 503 tyConGroups :: [TyCon] -> [TyConGroup]
 504 tyConGroups tcs = map mk_grp (stronglyConnComp edges)
 505   where
 506     edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs
 507                                 , let ds = tyConsOfTyCon tc]
 508
 509     mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds)
 510     mk_grp (CyclicSCC els)       = (tcs, unionManyUniqSets dss)
 511       where
 512         (tcs, dss) = unzip els
 513
 514 tyConsOfTyCon :: TyCon -> UniqSet TyCon
 515 tyConsOfTyCon
 516   = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons
 517
 518 tyConsOfType :: Type -> UniqSet TyCon
 519 tyConsOfType ty
 520   | Just ty' <- coreView ty    = tyConsOfType ty'
 521 tyConsOfType (TyVarTy v)       = emptyUniqSet
 522 tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys)
 523   where
 524     extend | isUnLiftedTyCon tc
 525            || isTupleTyCon   tc = id
 526
 527            | otherwise          = (`addOneToUniqSet` tc)
 528
 529 tyConsOfType (AppTy a b)       = tyConsOfType a `unionUniqSets` tyConsOfType b
 530 tyConsOfType (FunTy a b)       = (tyConsOfType a `unionUniqSets` tyConsOfType b)
 531                                  `addOneToUniqSet` funTyCon
 532 tyConsOfType (ForAllTy _ ty)   = tyConsOfType ty
 533 tyConsOfType other             = pprPanic "ClosureConv.tyConsOfType" $ ppr other
 534
 535 tyConsOfTypes :: [Type] -> UniqSet TyCon
 536 tyConsOfTypes = unionManyUniqSets . map tyConsOfType
 537