uuagc-0.9.55: src/LOAG/AOAG.hs
{-# LANGUAGE Rank2Types #-}
module LOAG.AOAG where
import LOAG.Common
import LOAG.Graphs
import LOAG.Rep
import AbstractSyntax
import CommonTypes
import Control.Arrow ((&&&), (***))
import Control.Monad (forM, forM_, MonadPlus(..), when, unless)
import Control.Monad.ST
import Control.Monad.State (MonadState(..))
import Data.Maybe (fromMaybe, catMaybes, fromJust, isNothing)
import Data.List (elemIndex, foldl', delete, (\\), insert, nub)
import Data.STRef
import Data.Tuple (swap)
import qualified Data.Set as S
import qualified Data.IntSet as IS
import qualified Data.IntMap as IM
import qualified Data.Map as M
import Data.Array.MArray
import qualified Data.Array as A
import Data.Array.ST
import ErrorMessages as Err
import Pretty
import UU.Scanner.Position
data Settings = Settings
{ -- current minimum ads size
prune_val :: Int
-- whether to minimize the number of fake dependencies
-- could be very costly
, min_ads :: Bool
}
default_settings = Settings 999 False
type AOAG s a = ST s a
-- | Catch a type 3 cycle-error made by a given constructor
-- | two alternatives are given to proceed
type ADS = [Edge]
type AOAGRes = Either Error LOAGRes
-- | Calculate a total order if the semantics given
-- originate from a linearly-ordered AG
type2error,limiterror,aoagerror :: Error
type2error = Err.CustomError False noPos $ text "Type 2 cycle"
limiterror = Err.CustomError False noPos $ text "Limit reached"
aoagerror = Err.CustomError False noPos $ text "Not an LOAG/AOAG"
schedule :: LOAGRep -> Grammar -> Ag -> [Edge] -> AOAGRes
schedule sem gram@(Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _)
ag@(Ag bounds_s bounds_p de nts) ads
= runST $ aoag default_settings ads
where
-- get the maps from semantics and translate them to functions
nmp = (nmp_LOAGRep_LOAGRep sem)
ofld = (ofld_LOAGRep_LOAGRep sem)
genA = gen_LOAGRep_LOAGRep sem
inss = inss_LOAGRep_LOAGRep sem
-- select candidates, using the edge that caused the cycle
-- from the list of intra-thread dependencies
-- (intra-visit dependencies without edges in ids)
candidates :: Edge -> Cycle -> [Edge] -> [Edge]
candidates _ c = foldr (\(f,t) acc ->
if f `IS.member` c &&t `IS.member` c
then (t,f):acc else acc) []
-- | Move occurrence to its corresponding attribute
gen :: Vertex -> Vertex
gen v = genA A.! v
genEdge :: Edge -> Edge
genEdge (f,t) = (gen f, gen t)
-- | Decide for a given production edge whether the vertices
-- belong to the same field
siblings :: Edge -> Bool
siblings (f, t) = ofld A.! f == ofld A.! t
-- | Given an nonterminal-edge, instantiate it
-- assumes that the occurrences of fields are added in the same order
instEdge :: Edge -> [Edge]
instEdge (f, t) = zip (inss A.! f) (inss A.! t)
aoag :: Settings -> [Edge] -> AOAG s AOAGRes
aoag cfg init_ads = run
where
run :: AOAG s AOAGRes
run = induced ads >>= detect
detect (Left err) = return $ Left err
detect (Right (dp,idp,ids@(idsf,idst))) = do
-- Attribute -> TimeSlot
schedA <- mapArray (const Nothing) idsf
-- map TimeSlot -> [Attribute]
schedS <- newSTRef $
foldr (\(Nonterminal nt _ _ _ _) -> M.insert (getName nt)
(IM.singleton 1 [])) M.empty dats
fr_ids <- freeze_graph ids
threads <- completing fr_ids (schedA, schedS) nts
let (ivd, comp) = fetchEdges fr_ids threads nts
eRoC <- m_edp dp init_ads ivd comp (schedA, schedS)
case eRoC of
Left res -> return $ Right res
Right (e,c,T3 cs) -> find_ads dp idp ids (schedA, schedS) e c cs
find_ads :: Graph s -> Graph s -> Graph s -> SchedRef s ->
Edge -> Cycle -> [Edge] -> AOAG s AOAGRes
find_ads dp idp ids sched e cycle comp = do
pruner <- newSTRef 999
explore dp idp ids sched init_ads pruner e cycle comp
explore :: Graph s -> Graph s -> Graph s -> SchedRef s ->
[Edge] -> STRef s Int -> Edge -> Cycle -> [Edge] ->
AOAG s AOAGRes
explore dp idp ids sched@(schedA, schedS) ads pruner e c comp =
explore' dp idp ids sched ads (candidates e c comp) pruner
where
explore' :: Graph s -> Graph s -> Graph s -> SchedRef s ->
[Edge] -> [Edge] -> STRef s Int ->
AOAG s AOAGRes
explore' _ _ _ _ _ [] _ = return $ Left aoagerror
explore' dp idp ids sched@(schedA,schedS) ads (fd:cs) pruner = do
p_val <- readSTRef pruner
if length ads >= p_val -1
then return $ Left limiterror
else do
idpf_clone <- mapArray id (fst idp)
idpt_clone <- mapArray id (snd idp)
let idp_c = (idpf_clone, idpt_clone)
idsf_clone <- mapArray id (fst ids)
idst_clone <- mapArray id (snd ids)
let ids_c = (idsf_clone, idst_clone)
schedA_c <- mapArray id schedA
schedS_v <- readSTRef schedS
schedS_c <- newSTRef schedS_v
let sched_c = (schedA_c, schedS_c)
let runM = reschedule dp idp ids sched
(fd:ads) fd pruner
let backtrack = explore' dp idp_c ids_c sched_c ads cs
pruner
maoag <- runM
case maoag of
Left _ -> backtrack
Right (tdp1,inf1,ads1) ->
if LOAG.AOAG.min_ads cfg
then do
writeSTRef pruner (length ads1)
maoag' <- backtrack
case maoag' of
Right (tdp2,inf2,ads2)
-> return $ Right (tdp2,inf2,ads2)
otherwise -> return $ Right (tdp1,inf1,ads1)
else return $ Right (tdp1,inf1,ads1)
-- step 1, 2 and 3
induced :: [Edge] -> AOAG s (Either Error (Graph s, Graph s, Graph s))
induced ads = do
dpf <- newArray bounds_p IS.empty
dpt <- newArray bounds_p IS.empty
idpf <- newArray bounds_p IS.empty
idpt <- newArray bounds_p IS.empty
idsf <- newArray bounds_s IS.empty
idst <- newArray bounds_s IS.empty
let ids = (idsf,idst)
let idp = (idpf,idpt)
let dp = (dpf ,dpt)
inducing dp idp ids (de ++ ads)
inducing :: Graph s -> Graph s -> Graph s -> [Edge]
-> AOAG s (Either Error (Graph s, Graph s, Graph s))
inducing dp idp ids es = do
res <- adds (addD dp idp ids) [] es
case res of
Left _ -> return $ Left $ type2error
Right _ -> return $ Right (dp, idp, ids)
addD :: Graph s -> Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge])
addD dp' idp' ids' e = do
resd <- e `insErt` dp'
resdp <- e `inserT` idp'
case resdp of
Right es -> adds (addN idp' ids') [] (e:es)
Left c -> return $ Left $ type2error
addI :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge])
addI idp' ids' e = do
exists <- member e idp'
if not exists then do
res <- e `inserT` idp'
case res of
Right es -> adds (addN idp' ids') [] es
Left c -> return $ Left $ type2error
else return $ Right []
adds f acc [] = return $ Right acc
adds f acc (e:es) = do
mes <- f e
case mes of
Left err -> return $ Left err
Right news -> adds f (acc++news) es
addN :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge])
addN idp' ids' e = do
if (siblings e) then do
let s_edge = genEdge e
exists <- member s_edge ids'
if not exists then do
_ <- inserT s_edge ids'
let es = instEdge s_edge
addedEx <- adds (addI idp' ids') [] es
case addedEx of
Right news -> return $ Right (s_edge : news)
Left err -> return $ Left err
else return $ Right []
else return $ Right []
-- step 6, 7
m_edp :: Graph s -> [Edge] -> [Edge] -> [Edge] -> SchedRef s ->
AOAG s (Either LOAGRes (Edge,Cycle,CType))
m_edp (dpf, dpt) ads ivd comp sched = do
edpf <- mapArray id dpf
edpt <- mapArray id dpt
mc <- addEDs (edpf,edpt) (concatMap instEdge ivd)
case mc of
Just (e, c) -> return $ Right (e,c,T3 $ concatMap instEdge comp)
Nothing -> do
tdp <- freeze edpt
infs <- readSTRef (snd sched)
return $ Left (Just tdp,infs,ads)
reschedule :: Graph s -> Graph s -> Graph s -> SchedRef s ->
[Edge] -> Edge -> STRef s Int
-> AOAG s AOAGRes
reschedule dp idp ids sched@(_,threadRef) ads e pruner = do
extra <- addN idp ids e
case extra of
Left err -> return $ Left err
Right extra -> do
forM_ extra $ swap_ivd ids sched
fr_ids <- freeze_graph ids
threads <- readSTRef threadRef
let (ivd, comp) = fetchEdges fr_ids threads nts
eRoC <- m_edp dp ads ivd comp sched
case eRoC of
Left res -> return $ Right res
Right (e,c,(T3 cs)) -> explore dp idp ids sched ads pruner e c cs
where
swap_ivd :: Graph s -> SchedRef s -> Edge -> AOAG s ()
swap_ivd ids@(idsf, idst) sr@(schedA, schedS) (f,t) = do
--the edge should point from higher to lower timeslot
assigned <- freeze schedA
let oldf = maybe (error "unassigned f") id $ assigned A.! f
oldt = maybe (error "unassigned t") id $ assigned A.! t
dirf = snd $ alab $ nmp M.! f
dirt = snd $ alab $ nmp M.! t
newf | oldf < oldt = oldt + (if dirf /= dirt then 1 else 0)
| otherwise = oldf
nt = show $ typeOf $ nmp M.! f
-- the edge was pointing in wrong direction so we moved
-- the attribute to a new interaction, now some of its
-- predecessors/ancestors might need to be moved too
unless (oldf == newf) $ do
writeArray schedA f (Just newf)
modifySTRef schedS
(M.adjust (IM.update (Just . delete f) oldf) nt)
modifySTRef schedS
(M.adjust(IM.alter(Just. maybe [f] (insert f))newf)nt)
predsf <- readArray idst f
succsf <- readArray idsf f
let rest = (map (flip (,) f) $ IS.toList predsf) ++
(map ((,) f) $ IS.toList succsf)
in mapM_ (swap_ivd ids sr) rest