cao-0.1: src/Language/CAO/Analysis/PhiInsert.hs

{-# LANGUAGE BangPatterns  #-}
{-# LANGUAGE PatternGuards #-}
{-
Module      :  $Header$
Description :  Insertion of phi function in SSA form.
Copyright   :  (c) SMART Team / HASLab
License     :  GPL

Maintainer  :  Paulo Silva <paufil@di.uminho.pt>
Stability   :  experimental
Portability :  non-portable

-}
module Language.CAO.Analysis.PhiInsert where

import Data.Graph ( Graph, Vertex )
import Data.List
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Maybe ( fromMaybe )
import Data.Set ( Set )
import qualified Data.Set as Set

import Language.CAO.Common.Var
import Language.CAO.Common.SrcLoc

import Language.CAO.Syntax
import Language.CAO.Syntax.Utils hiding ( getVars )

import Language.CAO.Analysis.Dominance
import Language.CAO.Analysis.CFG


--To decide what blocks require a phi
--function to join a definition to a variable
--v in block b:
--  1. Compute D1 = DF(b).
--  Place Phi functions at the head of all
--  members of D1.
--  
--  2. Compute D2 = DF(D1).
--  Place Phi functions at the head of all
--  members of D2-D1.
--  
--  3. Compute D3 = DF(D2).
--  Place Phi functions at the head of all
--  members of D3-D2-D1.
--  
--  4. Repeat until no additional Phi
--  functions can be added.

insertPhiFuncs :: Graph -> CaoCFG -> (CaoCFG, [Var])
insertPhiFuncs g cfg = (phiIns phiFuns cfg, allVars)
    where
    phiFuns :: Set (Vertex, Var, Int)
    phiFuns = phiLocArity g locOf
    allVars :: [Var]
    allVars = Map.keys locOf
    locOf   :: Map Var (Set Vertex)
    locOf   = Map.foldWithKey getLocs Map.empty (blocks cfg)

getLocs :: Vertex -> ([LStmt Var], [NodeId]) -> Map Var (Set Vertex)
        -> Map Var (Set Vertex)
getLocs nI (stmts, _) lo = foldl' (addVerts nI) lo $ getVars stmts

addVerts :: Vertex -> Map Var (Set Vertex) -> Var -> Map Var (Set Vertex)
addVerts nI lo v = Map.alter (addVertex nI) v lo

addVertex :: Vertex -> Maybe (Set Vertex) -> Maybe (Set Vertex)
addVertex v Nothing  = Just $ Set.singleton v
addVertex v (Just s) = Just $ Set.insert v s
        

phiLocArity :: Graph -> Map Var (Set Vertex) -> Set (Vertex, Var , Int)
phiLocArity g = Map.foldWithKey foldDf Set.empty
    where
    foldDf :: Var -> Set Vertex -> Set (Vertex, Var, Int)
           -> Set (Vertex, Var, Int)
    foldDf s v acc
        | Set.size v > 1 =
            Set.map (phiVarArity s) (followDf Set.empty v) `Set.union` acc
        | otherwise      = acc

    phiVarArity :: Var -> Vertex -> (Vertex, Var, Int)
    phiVarArity s v = (v, s, length $ predecessors g v)

    followDf :: Set Vertex -> Set Vertex -> Set Vertex
    followDf ini d1
        | d2 <- Set.fold getDF ini d1, d1 /= d2 = followDf d2 d2
        | otherwise                               = d1

    getDF :: Vertex -> Set Vertex -> Set Vertex
    getDF v s0 = Set.union s0 $ fromMaybe Set.empty $ Map.lookup v df

    df :: Map Vertex (Set Vertex)
    df = domFront g

phiIns :: Set (Vertex, Var, Int) -> CaoCFG -> CaoCFG
phiIns s cfg | Set.size s == 0 = cfg
             | otherwise       = phiIns s' cfg'
    where
    (phiAt@(_, n, _), s')  = Set.deleteFindMax s
    phiFunN                = mkPhiFunVar (varName n)
    cfg'                   = phiIns_ phiFunN phiAt cfg

phiIns_ :: Var -> (Vertex, Var, Int) -> CaoCFG -> CaoCFG
phiIns_ phiFunN (nodeI, vname, arity) cfg
    | nodeI == exitNode = cfg
    | otherwise         = addStmtAt nodeI phiFunAssign cfg
    where
    phiFunAssign :: LStmt Var
    phiFunAssign = genLoc $ Assign [lval] [phiFun]
    lval :: LVal Var
    lval = LVVar (genLoc vname)
    phiFun :: TLExpr Var
    -- XXX: Is this the correct annotation type?
    phiFun = genLoc $ annTyE (varType vname) $ FunCall (genLoc phiFunN) args
    args :: [TLExpr Var]
    args = map (genLoc . annTyE (varType vname) . Var) $ replicate arity vname

addStmtAt :: Vertex -> LStmt Var -> CaoCFG -> CaoCFG
addStmtAt nodeI stmt cfg = cfg { blocks = Map.insert nodeI (stmt:stmts, c) blk }
    where
    blk       = blocks cfg
    (stmts,c) = blk Map.! nodeI

getVars :: [LStmt Var] -> [Var]
getVars = concatMap (variableName . unLoc)
    where
    variableName :: Stmt Var -> [Var]
    variableName (VDecl v)          = Set.toList $ bvs v
    variableName (Assign lvalues _) = Set.toList $ fvs lvalues
    variableName _                  = []