ghc/compiler/ndpFlatten/PArrAnal.hs

   1 --  $Id$
   2 --
   3 --  Copyright (c) 2002 Manuel M T Chakravarty & Gabriele Keller
   4 --
   5 --  Analysis phase for an optimised flattening transformation
   6 --
   7 --- DESCRIPTION ---------------------------------------------------------------
   8 --
   9 --  This module implements an analysis phase that identifies Core expressions
  10 --  that need not be transformed during flattening.  The expressions when
  11 --  executed in a parallel context are implemented as an iteration over the
  12 --  original scalar computation, instead of vectorising the computation.  This
  13 --  usually improves efficiency by increasing locality and also reduces code
  14 --  size.
  15 --
  16 --- DOCU ----------------------------------------------------------------------
  17 --
  18 --  Language: Haskell 98 with C preprocessor
  19 --
  20 -- Analyse the expression and annotate each simple subexpression accordingly.
  21 --
  22 --  The result of the analysis is stored in a new field in IdInfo (has yet to
  23 --  be extended)
  24 --
  25 --  A simple expression is any expression which is not a function, not of
  26 --  recursive type and does not contain a value of PArray type. Polymorphic
  27 --  variables are simple expressions even though they might be instantiated to
  28 --  a parray value or function.
  29 --
  30 --- TODO ----------------------------------------------------------------------
  31 --
  32
  33 module PArrAnal (
  34   markScalarExprs       -- :: [CoreBind] -> [CoreBind]
  35 ) where
  36
  37 import Panic   (panic)
  38 import Outputable (pprPanic, ppr)
  39 import CoreSyn (CoreBind)
  40
  41 import TypeRep      (Type(..))
  42 import Var (Var(..),Id)
  43 import Literal      (Literal)
  44 import CoreSyn (Expr(..),CoreExpr,Bind(..))
  45 import PprCore ( {- instances -} )
  46 --
  47
  48 data ArrayUsage = Prim | NonPrim | Array
  49                 | PolyExpr (Id -> Maybe (ArrayUsage -> ArrayUsage))
  50                 | PolyFun (ArrayUsage -> ArrayUsage)
  51
  52
  53 arrUsage:: CoreExpr -> ArrayUsage
  54 arrUsage (Var id)  = varArrayUsage id
  55 arrUsage (Lit lit) = litArrayUsage lit
  56 arrUsage (App expr1 expr2) =
  57   let
  58     arr1 = arrUsage expr1
  59     arr2 = arrUsage expr2
  60   in
  61   case (arr1, arr2) of
  62     (_,        Array)  -> Array
  63     (PolyFun f, _)     -> f arr2
  64     (_, _)             -> arr1
  65
  66 arrUsage (Lam b expr) =
  67   bindType (b, expr)
  68
  69 arrUsage (Let (NonRec b expr1) expr2) =
  70   arrUsage (App (Lam b expr2) expr1)
  71
  72 arrUsage (Let (Rec bnds) expr) =
  73   let
  74     t1 = foldr combineArrayUsage Prim (map bindType bnds)
  75     t2 = arrUsage expr
  76   in if isArrayUsage t1 then Array else t2
  77
  78 arrUsage (Case expr b _ alts) =
  79   let
  80     t1 = arrUsage expr
  81     t2 = scanType (map (arrUsage . (\ (_,_,x) -> x)) alts)
  82   in scanType [t1, t2]
  83
  84 arrUsage (Note n expr) =
  85   arrUsage expr
  86
  87 arrUsage (Type t) =
  88   typeArrayUsage  t
  89
  90 bindType (b, expr) =
  91   let
  92     bT    = varArrayUsage b
  93     exprT = arrUsage expr
  94   in case (bT, exprT) of
  95        (Array, _) -> Array
  96        _          -> exprT
  97
  98 scanType:: [ArrayUsage] -> ArrayUsage
  99 scanType [t]        = t
 100 scanType (Array:ts) = Array
 101 scanType (_:ts)     = scanType ts
 102
 103
 104
 105 -- the code expression represents a built-in function which generates
 106 -- an array
 107 isArrayGen:: CoreExpr -> Bool
 108 isArrayGen _ =
 109   panic "PArrAnal: isArrayGen: not yet implemented"
 110
 111 isArrayCon:: CoreExpr -> Bool
 112 isArrayCon _ =
 113   panic "PArrAnal: isArrayCon: not yet implemented"
 114
 115 markScalarExprs:: [CoreBind] -> [CoreBind]
 116 markScalarExprs _ =
 117   panic "PArrAnal.markScalarExprs: not implemented yet"
 118
 119
 120 varArrayUsage:: Id -> ArrayUsage
 121 varArrayUsage =
 122   panic "PArrAnal.varArrayUsage: not yet implented"
 123
 124 litArrayUsage:: Literal -> ArrayUsage
 125 litArrayUsage =
 126   panic "PArrAnal.litArrayUsage: not yet implented"
 127
 128
 129 typeArrayUsage:: Type -> ArrayUsage
 130 typeArrayUsage (TyVarTy tvar) =
 131   PolyExpr (tIdFun tvar)
 132 typeArrayUsage (AppTy _ _) =
 133    panic "PArrAnal.typeArrayUsage: AppTy case not yet implemented"
 134 typeArrayUsage (TyConApp tc tcargs) =
 135   let
 136     tcargsAU = map typeArrayUsage tcargs
 137     tcCombine  = foldr combineArrayUsage Prim tcargsAU
 138   in auCon tcCombine
 139 typeArrayUsage t@(PredTy _) =
 140   pprPanic "PArrAnal.typeArrayUsage: encountered 'PredType - shouldn't be here!"
 141            (ppr t)
 142
 143
 144 combineArrayUsage:: ArrayUsage -> ArrayUsage -> ArrayUsage
 145 combineArrayUsage Array _  = Array
 146 combineArrayUsage _ Array  = Array
 147 combineArrayUsage (PolyExpr f1) (PolyExpr f2) =
 148   PolyExpr f'
 149   where
 150     f' var =
 151       let
 152         f1lookup = f1 var
 153         f2lookup = f2 var
 154        in
 155        case (f1lookup, f2lookup) of
 156          (Nothing, _) -> f2lookup
 157          (_, Nothing) -> f1lookup
 158          (Just f1', Just f2') -> Just ( \e -> (combineArrayUsage (f1' e) (f2' e)))
 159 combineArrayUsage (PolyFun f) (PolyExpr g) =
 160         panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++
 161                " constructor - should not (?) happen\n")
 162 combineArrayUsage (PolyExpr g) (PolyFun f)  =
 163         panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++
 164                " constructor - should not (?) happen\n")
 165 combineArrayUsage NonPrim _ = NonPrim
 166 combineArrayUsage _ NonPrim = NonPrim
 167 combineArrayUsage Prim Prim = Prim
 168
 169
 170 isArrayUsage:: ArrayUsage -> Bool
 171 isArrayUsage Array = True
 172 isArrayUsage _     = False
 173
 174 --  Functions to serve as arguments for PolyExpr
 175 --  ---------------------------------------------
 176
 177 tIdFun:: Var -> Var -> Maybe (ArrayUsage -> ArrayUsage)
 178 tIdFun t tcomp =
 179   if t == tcomp then
 180      Just auId
 181   else
 182      Nothing
 183
 184 -- Functions to serve as argument for PolyFun
 185 -- -------------------------------------------
 186
 187 auId:: ArrayUsage -> ArrayUsage
 188 auId = id
 189
 190 auCon:: ArrayUsage -> ArrayUsage
 191 auCon Prim = NonPrim
 192 auCon (PolyExpr f) = PolyExpr f'
 193   where f' v  = case f v of
 194                    Nothing -> Nothing
 195                    Just g  -> Just  ( \e -> (auCon (g e)))
 196 auCon (PolyFun f)  = PolyFun (auCon . f)
 197 auCon _    = Array
 198
 199 -- traversal of Core expressions
 200 -- -----------------------------
 201
 202 -- FIXME: implement
 203