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 -- gaw 2004
  79 arrUsage (Case expr b _ alts) =
  80   let
  81     t1 = arrUsage expr
  82     t2 = scanType (map (arrUsage . (\ (_,_,x) -> x)) alts)
  83   in scanType [t1, t2]
  84
  85 arrUsage (Note n expr) =
  86   arrUsage expr
  87
  88 arrUsage (Type t) =
  89   typeArrayUsage  t
  90
  91 bindType (b, expr) =
  92   let
  93     bT    = varArrayUsage b
  94     exprT = arrUsage expr
  95   in case (bT, exprT) of
  96        (Array, _) -> Array
  97        _          -> exprT
  98
  99 scanType:: [ArrayUsage] -> ArrayUsage
 100 scanType [t]        = t
 101 scanType (Array:ts) = Array
 102 scanType (_:ts)     = scanType ts
 103
 104
 105
 106 -- the code expression represents a built-in function which generates
 107 -- an array
 108 isArrayGen:: CoreExpr -> Bool
 109 isArrayGen _ =
 110   panic "PArrAnal: isArrayGen: not yet implemented"
 111
 112 isArrayCon:: CoreExpr -> Bool
 113 isArrayCon _ =
 114   panic "PArrAnal: isArrayCon: not yet implemented"
 115
 116 markScalarExprs:: [CoreBind] -> [CoreBind]
 117 markScalarExprs _ =
 118   panic "PArrAnal.markScalarExprs: not implemented yet"
 119
 120
 121 varArrayUsage:: Id -> ArrayUsage
 122 varArrayUsage =
 123   panic "PArrAnal.varArrayUsage: not yet implented"
 124
 125 litArrayUsage:: Literal -> ArrayUsage
 126 litArrayUsage =
 127   panic "PArrAnal.litArrayUsage: not yet implented"
 128
 129
 130 typeArrayUsage:: Type -> ArrayUsage
 131 typeArrayUsage (TyVarTy tvar) =
 132   PolyExpr (tIdFun tvar)
 133 typeArrayUsage (AppTy _ _) =
 134    panic "PArrAnal.typeArrayUsage: AppTy case not yet implemented"
 135 typeArrayUsage (TyConApp tc tcargs) =
 136   let
 137     tcargsAU = map typeArrayUsage tcargs
 138     tcCombine  = foldr combineArrayUsage Prim tcargsAU
 139   in auCon tcCombine
 140 typeArrayUsage t@(PredTy _) =
 141   pprPanic "PArrAnal.typeArrayUsage: encountered 'PredType - shouldn't be here!"
 142            (ppr t)
 143
 144
 145 combineArrayUsage:: ArrayUsage -> ArrayUsage -> ArrayUsage
 146 combineArrayUsage Array _  = Array
 147 combineArrayUsage _ Array  = Array
 148 combineArrayUsage (PolyExpr f1) (PolyExpr f2) =
 149   PolyExpr f'
 150   where
 151     f' var =
 152       let
 153         f1lookup = f1 var
 154         f2lookup = f2 var
 155        in
 156        case (f1lookup, f2lookup) of
 157          (Nothing, _) -> f2lookup
 158          (_, Nothing) -> f1lookup
 159          (Just f1', Just f2') -> Just ( \e -> (combineArrayUsage (f1' e) (f2' e)))
 160 combineArrayUsage (PolyFun f) (PolyExpr g) =
 161         panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++
 162                " constructor - should not (?) happen\n")
 163 combineArrayUsage (PolyExpr g) (PolyFun f)  =
 164         panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++
 165                " constructor - should not (?) happen\n")
 166 combineArrayUsage NonPrim _ = NonPrim
 167 combineArrayUsage _ NonPrim = NonPrim
 168 combineArrayUsage Prim Prim = Prim
 169
 170
 171 isArrayUsage:: ArrayUsage -> Bool
 172 isArrayUsage Array = True
 173 isArrayUsage _     = False
 174
 175 --  Functions to serve as arguments for PolyExpr
 176 --  ---------------------------------------------
 177
 178 tIdFun:: Var -> Var -> Maybe (ArrayUsage -> ArrayUsage)
 179 tIdFun t tcomp =
 180   if t == tcomp then
 181      Just auId
 182   else
 183      Nothing
 184
 185 -- Functions to serve as argument for PolyFun
 186 -- -------------------------------------------
 187
 188 auId:: ArrayUsage -> ArrayUsage
 189 auId = id
 190
 191 auCon:: ArrayUsage -> ArrayUsage
 192 auCon Prim = NonPrim
 193 auCon (PolyExpr f) = PolyExpr f'
 194   where f' v  = case f v of
 195                    Nothing -> Nothing
 196                    Just g  -> Just  ( \e -> (auCon (g e)))
 197 auCon (PolyFun f)  = PolyFun (auCon . f)
 198 auCon _    = Array
 199
 200 -- traversal of Core expressions
 201 -- -----------------------------
 202
 203 -- FIXME: implement
 204