diff options
Diffstat (limited to 'compiler/ndpFlatten/PArrAnal.hs')
| -rw-r--r-- | compiler/ndpFlatten/PArrAnal.hs | 203 |
1 files changed, 203 insertions, 0 deletions
diff --git a/compiler/ndpFlatten/PArrAnal.hs b/compiler/ndpFlatten/PArrAnal.hs new file mode 100644 index 0000000000..2db56221b2 --- /dev/null +++ b/compiler/ndpFlatten/PArrAnal.hs @@ -0,0 +1,203 @@ +-- $Id$ +-- +-- Copyright (c) 2002 Manuel M T Chakravarty & Gabriele Keller +-- +-- Analysis phase for an optimised flattening transformation +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This module implements an analysis phase that identifies Core expressions +-- that need not be transformed during flattening. The expressions when +-- executed in a parallel context are implemented as an iteration over the +-- original scalar computation, instead of vectorising the computation. This +-- usually improves efficiency by increasing locality and also reduces code +-- size. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 with C preprocessor +-- +-- Analyse the expression and annotate each simple subexpression accordingly. +-- +-- The result of the analysis is stored in a new field in IdInfo (has yet to +-- be extended) +-- +-- A simple expression is any expression which is not a function, not of +-- recursive type and does not contain a value of PArray type. Polymorphic +-- variables are simple expressions even though they might be instantiated to +-- a parray value or function. +-- +--- TODO ---------------------------------------------------------------------- +-- + +module PArrAnal ( + markScalarExprs -- :: [CoreBind] -> [CoreBind] +) where + +import Panic (panic) +import Outputable (pprPanic, ppr) +import CoreSyn (CoreBind) + +import TypeRep (Type(..)) +import Var (Var(..),Id) +import Literal (Literal) +import CoreSyn (Expr(..),CoreExpr,Bind(..)) +import PprCore ( {- instances -} ) +-- + +data ArrayUsage = Prim | NonPrim | Array + | PolyExpr (Id -> Maybe (ArrayUsage -> ArrayUsage)) + | PolyFun (ArrayUsage -> ArrayUsage) + + +arrUsage:: CoreExpr -> ArrayUsage +arrUsage (Var id) = varArrayUsage id +arrUsage (Lit lit) = litArrayUsage lit +arrUsage (App expr1 expr2) = + let + arr1 = arrUsage expr1 + arr2 = arrUsage expr2 + in + case (arr1, arr2) of + (_, Array) -> Array + (PolyFun f, _) -> f arr2 + (_, _) -> arr1 + +arrUsage (Lam b expr) = + bindType (b, expr) + +arrUsage (Let (NonRec b expr1) expr2) = + arrUsage (App (Lam b expr2) expr1) + +arrUsage (Let (Rec bnds) expr) = + let + t1 = foldr combineArrayUsage Prim (map bindType bnds) + t2 = arrUsage expr + in if isArrayUsage t1 then Array else t2 + +arrUsage (Case expr b _ alts) = + let + t1 = arrUsage expr + t2 = scanType (map (arrUsage . (\ (_,_,x) -> x)) alts) + in scanType [t1, t2] + +arrUsage (Note n expr) = + arrUsage expr + +arrUsage (Type t) = + typeArrayUsage t + +bindType (b, expr) = + let + bT = varArrayUsage b + exprT = arrUsage expr + in case (bT, exprT) of + (Array, _) -> Array + _ -> exprT + +scanType:: [ArrayUsage] -> ArrayUsage +scanType [t] = t +scanType (Array:ts) = Array +scanType (_:ts) = scanType ts + + + +-- the code expression represents a built-in function which generates +-- an array +isArrayGen:: CoreExpr -> Bool +isArrayGen _ = + panic "PArrAnal: isArrayGen: not yet implemented" + +isArrayCon:: CoreExpr -> Bool +isArrayCon _ = + panic "PArrAnal: isArrayCon: not yet implemented" + +markScalarExprs:: [CoreBind] -> [CoreBind] +markScalarExprs _ = + panic "PArrAnal.markScalarExprs: not implemented yet" + + +varArrayUsage:: Id -> ArrayUsage +varArrayUsage = + panic "PArrAnal.varArrayUsage: not yet implented" + +litArrayUsage:: Literal -> ArrayUsage +litArrayUsage = + panic "PArrAnal.litArrayUsage: not yet implented" + + +typeArrayUsage:: Type -> ArrayUsage +typeArrayUsage (TyVarTy tvar) = + PolyExpr (tIdFun tvar) +typeArrayUsage (AppTy _ _) = + panic "PArrAnal.typeArrayUsage: AppTy case not yet implemented" +typeArrayUsage (TyConApp tc tcargs) = + let + tcargsAU = map typeArrayUsage tcargs + tcCombine = foldr combineArrayUsage Prim tcargsAU + in auCon tcCombine +typeArrayUsage t@(PredTy _) = + pprPanic "PArrAnal.typeArrayUsage: encountered 'PredType - shouldn't be here!" + (ppr t) + + +combineArrayUsage:: ArrayUsage -> ArrayUsage -> ArrayUsage +combineArrayUsage Array _ = Array +combineArrayUsage _ Array = Array +combineArrayUsage (PolyExpr f1) (PolyExpr f2) = + PolyExpr f' + where + f' var = + let + f1lookup = f1 var + f2lookup = f2 var + in + case (f1lookup, f2lookup) of + (Nothing, _) -> f2lookup + (_, Nothing) -> f1lookup + (Just f1', Just f2') -> Just ( \e -> (combineArrayUsage (f1' e) (f2' e))) +combineArrayUsage (PolyFun f) (PolyExpr g) = + panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++ + " constructor - should not (?) happen\n") +combineArrayUsage (PolyExpr g) (PolyFun f) = + panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++ + " constructor - should not (?) happen\n") +combineArrayUsage NonPrim _ = NonPrim +combineArrayUsage _ NonPrim = NonPrim +combineArrayUsage Prim Prim = Prim + + +isArrayUsage:: ArrayUsage -> Bool +isArrayUsage Array = True +isArrayUsage _ = False + +-- Functions to serve as arguments for PolyExpr +-- --------------------------------------------- + +tIdFun:: Var -> Var -> Maybe (ArrayUsage -> ArrayUsage) +tIdFun t tcomp = + if t == tcomp then + Just auId + else + Nothing + +-- Functions to serve as argument for PolyFun +-- ------------------------------------------- + +auId:: ArrayUsage -> ArrayUsage +auId = id + +auCon:: ArrayUsage -> ArrayUsage +auCon Prim = NonPrim +auCon (PolyExpr f) = PolyExpr f' + where f' v = case f v of + Nothing -> Nothing + Just g -> Just ( \e -> (auCon (g e))) +auCon (PolyFun f) = PolyFun (auCon . f) +auCon _ = Array + +-- traversal of Core expressions +-- ----------------------------- + +-- FIXME: implement + |