{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details

--  $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

-- not quite sure this is right
arrUsage (Cast expr co) =
  arrUsage expr 

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