Vectorise.hs 3.48 KB
Newer Older
1 2 3 4 5 6 7 8
module Vectorise( vectorise )
where

#include "HsVersions.h"

import DynFlags
import HscTypes

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
9 10 11 12 13 14 15 16 17
import CoreLint       ( showPass, endPass )
import TyCon
import Var
import VarEnv

import DsMonad

import PrelNames

18 19 20
vectorise :: HscEnv -> ModGuts -> IO ModGuts
vectorise hsc_env guts
  | not (Opt_Vectorise `dopt` dflags) = return guts
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
21 22 23 24 25 26 27 28 29 30 31
  | otherwise
  = do
      showPass dflags "Vectorisation"
      eps <- hscEPS hsc_env
      let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps
      Just guts' <- initDs hsc_env (mg_module guts)
                                   (mg_rdr_env guts)
                                   (mg_types guts)
                                   (vectoriseModule info guts)
      endPass dflags "Vectorisation" Opt_D_dump_vect (mg_binds guts')
      return guts'
32 33 34
  where
    dflags = hsc_dflags hsc_env

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
-- ----------------------------------------------------------------------------
-- Vectorisation monad

data Builtins = Builtins {
                  parrayTyCon      :: TyCon
                , paTyCon          :: TyCon
                , closureTyCon     :: TyCon
                , mkClosureVar     :: Var
                , applyClosureVar  :: Var
                , mkClosurePVar    :: Var
                , applyClosurePVar :: Var
                , closurePAVar     :: Var
                , lengthPAVar      :: Var
                , replicatePAVar   :: Var
                }

initBuiltins :: DsM Builtins
initBuiltins
  = do
      parrayTyCon  <- dsLookupTyCon parrayTyConName
      paTyCon      <- dsLookupTyCon paTyConName
      closureTyCon <- dsLookupTyCon closureTyConName

      mkClosureVar     <- dsLookupGlobalId mkClosureName
      applyClosureVar  <- dsLookupGlobalId applyClosureName
      mkClosurePVar    <- dsLookupGlobalId mkClosurePName
      applyClosurePVar <- dsLookupGlobalId applyClosurePName
      closurePAVar     <- dsLookupGlobalId closurePAName
      lengthPAVar      <- dsLookupGlobalId lengthPAName
      replicatePAVar   <- dsLookupGlobalId replicatePAName

      return $ Builtins {
                 parrayTyCon      = parrayTyCon
               , paTyCon          = paTyCon
               , closureTyCon     = closureTyCon
               , mkClosureVar     = mkClosureVar
               , applyClosureVar  = applyClosureVar
               , mkClosurePVar    = mkClosurePVar
               , applyClosurePVar = applyClosurePVar
               , closurePAVar     = closurePAVar
               , lengthPAVar      = lengthPAVar
               , replicatePAVar   = replicatePAVar
               }

data VEnv = VEnv {
              -- Mapping from variables to their vectorised versions
              --
              vect_vars :: VarEnv Var
            }

initVEnv :: VectInfo -> DsM VEnv
initVEnv info
  = return $ VEnv {
               vect_vars = mapVarEnv snd $ vectInfoCCVar info
             }

-- FIXME
updVectInfo :: VEnv -> VectInfo -> VectInfo
updVectInfo env info = info

newtype VM a = VM { runVM :: Builtins -> VEnv -> DsM (VEnv, a) }

instance Monad VM where
  return x   = VM $ \bi env -> return (env, x)
  VM p >>= f = VM $ \bi env -> do
                                 (env', x) <- p bi env
                                 runVM (f x) bi env'

vectoriseModule :: VectInfo -> ModGuts -> DsM ModGuts
vectoriseModule info guts
  = do
      builtins <- initBuiltins
      env <- initVEnv info
      (env', guts') <- runVM (vectModule guts) builtins env
      return $ guts' { mg_vect_info = updVectInfo env' info }

vectModule :: ModGuts -> VM ModGuts
vectModule guts = return guts