compiler/vectorise/Vectorise.hs

   1 module Vectorise( vectorise )
   2 where
   3
   4 #include "HsVersions.h"
   5
   6 import DynFlags
   7 import HscTypes
   8
   9 import CoreLint       ( showPass, endPass )
  10 import TyCon
  11 import Var
  12 import VarEnv
  13
  14 import DsMonad
  15
  16 import PrelNames
  17
  18 vectorise :: HscEnv -> ModGuts -> IO ModGuts
  19 vectorise hsc_env guts
  20   | not (Opt_Vectorise `dopt` dflags) = return guts
  21   | otherwise
  22   = do
  23       showPass dflags "Vectorisation"
  24       eps <- hscEPS hsc_env
  25       let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps
  26       Just guts' <- initDs hsc_env (mg_module guts)
  27                                    (mg_rdr_env guts)
  28                                    (mg_types guts)
  29                                    (vectoriseModule info guts)
  30       endPass dflags "Vectorisation" Opt_D_dump_vect (mg_binds guts')
  31       return guts'
  32   where
  33     dflags = hsc_dflags hsc_env
  34
  35 -- ----------------------------------------------------------------------------
  36 -- Vectorisation monad
  37
  38 data Builtins = Builtins {
  39                   parrayTyCon      :: TyCon
  40                 , paTyCon          :: TyCon
  41                 , closureTyCon     :: TyCon
  42                 , mkClosureVar     :: Var
  43                 , applyClosureVar  :: Var
  44                 , mkClosurePVar    :: Var
  45                 , applyClosurePVar :: Var
  46                 , closurePAVar     :: Var
  47                 , lengthPAVar      :: Var
  48                 , replicatePAVar   :: Var
  49                 }
  50
  51 initBuiltins :: DsM Builtins
  52 initBuiltins
  53   = do
  54       parrayTyCon  <- dsLookupTyCon parrayTyConName
  55       paTyCon      <- dsLookupTyCon paTyConName
  56       closureTyCon <- dsLookupTyCon closureTyConName
  57
  58       mkClosureVar     <- dsLookupGlobalId mkClosureName
  59       applyClosureVar  <- dsLookupGlobalId applyClosureName
  60       mkClosurePVar    <- dsLookupGlobalId mkClosurePName
  61       applyClosurePVar <- dsLookupGlobalId applyClosurePName
  62       closurePAVar     <- dsLookupGlobalId closurePAName
  63       lengthPAVar      <- dsLookupGlobalId lengthPAName
  64       replicatePAVar   <- dsLookupGlobalId replicatePAName
  65
  66       return $ Builtins {
  67                  parrayTyCon      = parrayTyCon
  68                , paTyCon          = paTyCon
  69                , closureTyCon     = closureTyCon
  70                , mkClosureVar     = mkClosureVar
  71                , applyClosureVar  = applyClosureVar
  72                , mkClosurePVar    = mkClosurePVar
  73                , applyClosurePVar = applyClosurePVar
  74                , closurePAVar     = closurePAVar
  75                , lengthPAVar      = lengthPAVar
  76                , replicatePAVar   = replicatePAVar
  77                }
  78
  79 data VEnv = VEnv {
  80               -- Mapping from variables to their vectorised versions
  81               --
  82               vect_vars :: VarEnv Var
  83             }
  84
  85 initVEnv :: VectInfo -> DsM VEnv
  86 initVEnv info
  87   = return $ VEnv {
  88                vect_vars = mapVarEnv snd $ vectInfoCCVar info
  89              }
  90
  91 -- FIXME
  92 updVectInfo :: VEnv -> VectInfo -> VectInfo
  93 updVectInfo env info = info
  94
  95 newtype VM a = VM { runVM :: Builtins -> VEnv -> DsM (VEnv, a) }
  96
  97 instance Monad VM where
  98   return x   = VM $ \bi env -> return (env, x)
  99   VM p >>= f = VM $ \bi env -> do
 100                                  (env', x) <- p bi env
 101                                  runVM (f x) bi env'
 102
 103 vectoriseModule :: VectInfo -> ModGuts -> DsM ModGuts
 104 vectoriseModule info guts
 105   = do
 106       builtins <- initBuiltins
 107       env <- initVEnv info
 108       (env', guts') <- runVM (vectModule guts) builtins env
 109       return $ guts' { mg_vect_info = updVectInfo env' info }
 110
 111 vectModule :: ModGuts -> VM ModGuts
 112 vectModule guts = return guts
 113