compiler/vectorise/VectCore.hs

   1 {-# OPTIONS -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
   6 -- for details
   7
   8 module VectCore (
   9   Vect, VVar, VExpr, VBind,
  10
  11   vectorised, lifted,
  12   mapVect,
  13
  14   vNonRec, vRec,
  15
  16   vVar, vType, vNote, vLet,
  17   vLams, vLamsWithoutLC, vVarApps,
  18   vCaseDEFAULT, vCaseProd
  19 ) where
  20
  21 #include "HsVersions.h"
  22
  23 import CoreSyn
  24 import CoreUtils      ( exprType )
  25 import DataCon        ( DataCon )
  26 import Type           ( Type )
  27 import Id             ( mkWildId )
  28 import Var
  29
  30 type Vect a = (a,a)
  31 type VVar   = Vect Var
  32 type VExpr  = Vect CoreExpr
  33 type VBind  = Vect CoreBind
  34
  35 vectorised :: Vect a -> a
  36 vectorised = fst
  37
  38 lifted :: Vect a -> a
  39 lifted = snd
  40
  41 mapVect :: (a -> b) -> Vect a -> Vect b
  42 mapVect f (x,y) = (f x, f y)
  43
  44 zipWithVect :: (a -> b -> c) -> Vect a -> Vect b -> Vect c
  45 zipWithVect f (x1,y1) (x2,y2) = (f x1 x2, f y1 y2)
  46
  47 vVar :: VVar -> VExpr
  48 vVar = mapVect Var
  49
  50 vType :: Type -> VExpr
  51 vType ty = (Type ty, Type ty)
  52
  53 vNote :: Note -> VExpr -> VExpr
  54 vNote = mapVect . Note
  55
  56 vNonRec :: VVar -> VExpr -> VBind
  57 vNonRec = zipWithVect NonRec
  58
  59 vRec :: [VVar] -> [VExpr] -> VBind
  60 vRec vs es = (Rec (zip vvs ves), Rec (zip lvs les))
  61   where
  62     (vvs, lvs) = unzip vs
  63     (ves, les) = unzip es
  64
  65 vLet :: VBind -> VExpr -> VExpr
  66 vLet = zipWithVect Let
  67
  68 vLams :: Var -> [VVar] -> VExpr -> VExpr
  69 vLams lc vs (ve, le) = (mkLams vvs ve, mkLams (lc:lvs) le)
  70   where
  71     (vvs,lvs) = unzip vs
  72
  73 vLamsWithoutLC :: [VVar] -> VExpr -> VExpr
  74 vLamsWithoutLC vvs (ve,le) = (mkLams vs ve, mkLams ls le)
  75   where
  76     (vs,ls) = unzip vvs
  77
  78 vVarApps :: Var -> VExpr -> [VVar] -> VExpr
  79 vVarApps lc (ve, le) vvs = (ve `mkVarApps` vs, le `mkVarApps` (lc : ls))
  80   where
  81     (vs,ls) = unzip vvs
  82
  83 vCaseDEFAULT :: VExpr -> VVar -> Type -> Type -> VExpr -> VExpr
  84 vCaseDEFAULT (vscrut, lscrut) (vbndr, lbndr) vty lty (vbody, lbody)
  85   = (Case vscrut vbndr vty (mkDEFAULT vbody),
  86      Case lscrut lbndr lty (mkDEFAULT lbody))
  87   where
  88     mkDEFAULT e = [(DEFAULT, [], e)]
  89
  90 vCaseProd :: VExpr -> Type -> Type
  91           -> DataCon -> DataCon -> [Var] -> [VVar] -> VExpr -> VExpr
  92 vCaseProd (vscrut, lscrut) vty lty vdc ldc sh_bndrs bndrs
  93           (vbody,lbody)
  94   = (Case vscrut (mkWildId $ exprType vscrut) vty
  95           [(DataAlt vdc, vbndrs, vbody)],
  96      Case lscrut (mkWildId $ exprType lscrut) lty
  97           [(DataAlt ldc, sh_bndrs ++ lbndrs, lbody)])
  98   where
  99     (vbndrs, lbndrs) = unzip bndrs