uuagc-0.9.52: src-ag/LOAG/Order.ag
INCLUDE "AbstractSyntax"
INCLUDE "Patterns"
INCLUDE "CodeSyntax"
INCLUDE "Expression"
INCLUDE "HsToken"
INCLUDE "LOAG/Rep"
INCLUDE "LOAG/Prepare"
INCLUDE "ExecutionPlanCommon"
MODULE {LOAG.Order}
{}
{}
imports{
import qualified Data.Array as A
import qualified Data.Map as Map
import qualified Data.IntMap as IMap
import qualified Data.Set as Set
import qualified Data.IntSet as IS
import qualified Data.Sequence as Seq
import qualified CommonTypes as CT
import Control.Monad (forM,when)
import Control.Monad.ST
import Data.Maybe(catMaybes)
import Data.Monoid(mappend,mempty)
import Data.STRef
import AbstractSyntax
import qualified LOAG.AOAG as AOAG
import LOAG.Common
import LOAG.Chordal
import LOAG.Rep
import LOAG.Graphs
import CodeSyntax
import Data.Maybe (isJust, fromJust)
import ExecutionPlan
import GrammarInfo
import HsToken (HsToken(..))
import Pretty
import qualified System.IO as IO
import System.IO.Unsafe
}
{
fst' (a,_,_) = a
snd' (_,b,_) = b
trd' (_,_,c) = c
}
ATTR Grammar [ | |
output : ExecutionPlan
ads : {Maybe PP_Doc}
errors : {Seq.Seq Error}]
SEM Grammar | Grammar
lhs.errors = either Seq.singleton (const Seq.empty) @loc.schedRes
lhs.ads = case either (const []) trd' @loc.schedRes of
[] -> Nothing
ads -> Just $ ppAds @lhs.options @nonts.pmp ads
lhs.output = ExecutionPlan @nonts.enonts @typeSyns @wrappers @derivings
nonts.sched = either (const Map.empty) snd' @loc.schedRes
nonts.tdp = either (error "no tdp") (fromJust.fst') @loc.schedRes
loc.schedRes = if CT.loag @lhs.options
then if CT.aoag @lhs.options
then AOAG.schedule @smf.self @self @loc.ag @nonts.ads
else @loc.loagRes
else Right (Nothing,Map.empty,[])
loc.loagRes = let putStrLn s = when (verbose @lhs.options) (IO.putStrLn s)
in Right $ unsafePerformIO $ scheduleLOAG @loc.ag putStrLn @lhs.options
loc.ag = repToAg @smf.self @self
nonts.res_ads = either (const []) trd' @loc.schedRes
-- Gather the fake dependencies from the ads result of AOAG
ATTR Nonterminals Nonterminal Productions Production
[ res_ads : {[Edge]} || ]
ATTR Nonterminals Nonterminal
[ || fdps USE {Map.union} {Map.empty} : AttrOrderMap ]
SEM Nonterminal | Nonterminal
lhs.fdps = Map.singleton @nt @prods.fdps
ATTR Productions Production [ ||
fdps USE {Map.union} {Map.empty} : {Map.Map ConstructorIdent (Set Dependency)} ]
SEM Production | Production
lhs.fdps =
let op d@(f,t) ds
| fst (argsOf $ findWithErr @lhs.pmpf "fdps" f) == (@lhs.dty,getName @con)
= Set.insert (edgeToDep @lhs.pmpf d) ds
| otherwise
= ds
in Map.singleton @con $ foldr op Set.empty @lhs.res_ads
{
data AltAttr = AltAttr Identifier Identifier Bool
deriving (Eq, Ord, Show)
edgeToDep :: PMP -> Edge -> Dependency
edgeToDep pmp (f,t) =
Dependency (OccAttr (identifier f1) (identifier i1))
(OccAttr (identifier f2) (identifier i2))
where (MyOccurrence (_,f1) (i1,_),MyOccurrence (_,f2) (i2,_))
= (findWithErr pmp "edgeToDep" f,
findWithErr pmp "edgeToDep" t)
ppAds :: Options -> PMP -> [Edge] -> PP_Doc
ppAds opts pmp = foldr ((>-<) . ppEdge opts pmp) empty
ppEdge :: Options -> PMP -> Edge -> PP_Doc
ppEdge opts pmp (f,t) =
text sem >#< text (show ty) >|< " | " >|< text p >|< " "
>|< ppOcc pmp f >|< text " < " >|< ppOcc pmp t
where (MyOccurrence ((ty,p),_) _) = pmp Map.! f
sem | lcKeywords opts = "sem"
| otherwise = "SEM"
ppOcc :: PMP -> Vertex -> PP_Doc
ppOcc pmp v = text f >|< text "." >|< fst a
where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v
}
-- Construct Execution Plan
ATTR Nonterminals Nonterminal [
visMapf : {IMap.IntMap Int}
tdp : TDPRes ||
enonts USE {(++)} {[]} : ENonterminals
visMap USE {IMap.union} {IMap.empty} : {IMap.IntMap Int}]
SEM Grammar
| Grammar nonts.visMapf = @nonts.visMap
nonts.visitnum = 0
SEM Nonterminal
| Nonterminal
loc.initial = @lhs.visitnum
loc.vnums = zipWith const [@loc.initial..] @segments
loc.initialVisit = @vnums
loc.nextVis = Map.fromList $ (@loc.initial + length @vnums, NoneVis)
: [(v, OneVis v) | v <- @vnums ]
loc.prevVis = Map.fromList $ (@loc.initial, NoneVis)
: [(v+1, OneVis v) | v <- @vnums ]
loc.visMap = let op vnr (MySegment visnr ins syns _ _) =
IMap.fromList $ zip syns (repeat vnr)
in IMap.unions $ zipWith op [@loc.initial..] @mysegments
lhs.enonts = [ENonterminal
@nt
@params
@loc.classContexts
@loc.initial
@loc.initialVisit
@loc.nextVis
@loc.prevVis
@prods.eprods
@loc.recursive
@loc.hoInfo ]
ATTR Productions Production [
visMapf : {IMap.IntMap Int}
tdp : TDPRes ||
eprods USE {(++)} {[]} : EProductions ]
SEM Production
| Production
segs.ruleMap = @rules.ruleMap
segs.done = (Set.empty, Set.empty, Set.empty, Set.empty)
loc.intros = let intro (Child nm _ kind)
| kind == ChildAttr = Nothing
| otherwise = Just $ ChildIntro nm
in catMaybes $ map intro @children.self
lhs.eprods =
let ((Visit ident from to inh syn steps kind):vss) = @segs.evisits
steps' = @loc.intros ++ steps
visits | null @segs.evisits = []
| otherwise =
((Visit ident from to inh syn steps' kind):vss)
in [EProduction
@con
@params
@constraints
@rules.erules
@children.echilds
visits ]
ATTR Nonterminals Nonterminal Productions Production MySegments MySegment
[ | visitnum : Int | ]
-- Visit nums should be the same for each production, but different globally
SEM Productions
| Cons tl.visitnum = @lhs.visitnum
lhs.visitnum = @hd.visitnum
SEM MySegment | MySegment +visitnum = (+1)
ATTR MySegments MySegment [
-- maps which attribute occurrence is calculated in which visit
visMapf : {IMap.IntMap Int} | | ]
ATTR MySegments MySegment [
ps : PLabel
ruleMap : {Map.Map MyOccurrence Identifier}
nmprf : NMP_R
options : {Options}
tdp : TDPRes
done : { (Set.Set MyOccurrence, Set.Set FLabel
, Set.Set Identifier, Set.Set (FLabel,Int))}
||]
ATTR MySegments [|| evisits USE {:} {[]} : {Visits}]
ATTR MySegment [||
evisits : {Visit}
-- synthesized attribute occurrences of this segment
synsO : {[Int]}
visnr : Int
done : { (Set.Set MyOccurrence, Set.Set FLabel
,Set.Set Identifier, Set.Set (FLabel,Int))}]
SEM MySegments
| Cons hd.done = @lhs.done
tl.done = @hd.done
SEM MySegment
| MySegment
loc.inhs = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @inhAttr
loc.syns = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @synAttr
loc.inhsO= maybe (error "segment not instantiated") id @inhOccs
loc.synsO= maybe (error "segment not instantiated") id @synOccs
lhs.visnr= @visnr
loc.kind = if monadic @lhs.options then VisitMonadic else VisitPure True
lhs.evisits = Visit @lhs.visitnum @lhs.visitnum (@lhs.visitnum+1)
@loc.inhs @loc.syns @loc.steps @loc.kind
loc.steps = if monadic @lhs.options
then [Sim @loc.vss] else [PureGroup @loc.vss True]
(loc.vss,lhs.done) = (runST $ getVss @lhs.done @lhs.ps @lhs.tdp @synsO
@lhs.lfpf @lhs.nmprf @lhs.pmpf @lhs.pmprf @lhs.fty
@lhs.visMapf @lhs.ruleMap @lhs.hoMapf)
{
getVss (done,intros,rules,vnrs) ps tdp synsO lfp nmpr pmp pmpr fty visMap ruleMap hoMap = do
ref <- newSTRef done
introed <- newSTRef intros
ruleref <- newSTRef rules
vnrsref <- newSTRef vnrs
lists <- forM synsO (visit ref introed ruleref vnrsref . (pmp Map.!))
done <- readSTRef ref
intros <- readSTRef introed
rules <- readSTRef ruleref
vnrs <- readSTRef vnrsref
return (concat lists, (done, intros, rules, vnrs))
where
hochildren = maybe Set.empty id $ Map.lookup ps hoMap
visit ref introed ruleref vnrsref o@(MyOccurrence (_,f) (_,d)) = do
visited <- readSTRef ref
if (o `Set.member` visited)
then return [] -- already visited
else do -- prevent doubles
modifySTRef ref (Set.insert o)
if inOutput
then do -- has to be calculated in this sequence
rest' <- rest
locs' <- locs
sem' <- sem o
return $ (rest' ++ locs' ++ sem')
else if "lhs" == (snd $ argsOf o)
then return [] -- inherited of parent, nothing todo
else do -- other input occurrence, perform visit
locs' <- locs
rest' <- rest
visit'<- toVisit o
return (rest' ++ locs' ++ visit')
where preds = maybe [] (IS.toList . (tdp A.!)) $ Map.lookup o pmpr
rest = forM preds (visit ref introed ruleref vnrsref. (pmp Map.!))
>>= (return . concat)
free = maybe [] (Set.toList) $ Map.lookup o lfp
locs = forM free (visit ref introed ruleref vnrsref)
>>= (return . concat)
sem o = do rules <- readSTRef ruleref
if r `Set.member` rules
then return []
else do writeSTRef ruleref (r `Set.insert` rules)
return [Sem r]
where r = maybe (error "ruleMap") id $ Map.lookup o ruleMap
inOutput = f == "lhs" && d == Syn || f /= "lhs" && d == Inh
toVisit o = do
vnrs <- readSTRef vnrsref
if (child,visnr) `Set.member` vnrs
then return []
else writeSTRef vnrsref ((child,visnr) `Set.insert` vnrs) >>
if child `Set.member` hochildren
then do intros <- readSTRef introed
case child `Set.member` intros of
True -> return [cvisit]
False -> do
writeSTRef introed (Set.insert child intros)
let occ = (ps,"inst") >.< (child, AnyDir)
preds = Set.toList $ setConcatMap rep $
lfp Map.! occ
rep :: MyOccurrence -> Set.Set MyOccurrence
rep occ | isLoc occ = Set.insert occ $
setConcatMap rep $ lfp Map.! occ
| otherwise = Set.singleton occ
rest <- forM preds
(visit ref introed ruleref vnrsref)
sem' <- sem occ
return $ (concat rest) ++
sem' ++
[ChildIntro (identifier child)] ++
[cvisit]
else return [cvisit]
where cvisit= ChildVisit (identifier child) ntid visnr
child = snd $ argsOf o
ntid = ((\(NT name _ _ )-> name) . fromMyTy) nt
visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o))
nt = fty Map.! (ps,child)
}
ATTR Nonterminals Nonterminal [
sched : {InterfaceRes} ||]
SEM Nonterminal
| Nonterminal
loc.assigned = findWithErr @lhs.sched "could not const. interfaces"
(getName @nt)
loc.mx = if Map.null @lhs.sched
then 0
else let mx = fst $ IMap.findMax @loc.assigned in
if even mx then mx else mx + 1
loc.mysegments =
map (\i -> MySegment ((@loc.mx - i) `div` 2)
(maybe [] id $ IMap.lookup i @loc.assigned)
(maybe [] id $ IMap.lookup (i-1) @loc.assigned)
Nothing Nothing)
[@loc.mx,@loc.mx-2 .. 2]
loc.segments =
map (\(MySegment visnr is ss _ _) ->
CSegment (Map.unions $ map (vertexToAttr @lhs.nmp) is)
(Map.unions $ map (vertexToAttr @lhs.nmp) ss))
@loc.mysegments
ATTR Productions Production [ mysegments : MySegments || ]
SEM Production
| Production
inst.segs : MySegments
--translate from attribute to occurrences
inst.segs =
map (\(MySegment visnr inhs syns _ _) ->
MySegment visnr inhs syns
(Just $ map (@lhs.pmprf Map.!) $
handAllOut (@loc.ps,"lhs") $
map (@lhs.nmp Map.!) inhs)
(Just $ map (@lhs.pmprf Map.!) $
handAllOut (@loc.ps,"lhs") $
map (@lhs.nmp Map.!) syns)
) @lhs.mysegments
{
repToAg :: LOAGRep -> Grammar -> Ag
repToAg sem (Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) =
Ag bounds_s bounds_p de (map toNt dats)
where
pmp = (pmp_LOAGRep_LOAGRep sem)
pmpr = (pmpr_LOAGRep_LOAGRep sem)
nmp = (nmp_LOAGRep_LOAGRep sem)
nmpr = (nmpr_LOAGRep_LOAGRep sem)
genA = gen_LOAGRep_LOAGRep sem
fieldM = fieldMap_LOAGRep_LOAGRep sem
genEdge (f,t) = (gen f, gen t)
fsInP = map2F (fsInP_LOAGRep_LOAGRep sem)
siblings (f, t) = ofld A.! f == ofld A.! t
ofld = (ofld_LOAGRep_LOAGRep sem)
sfp = map2F' (sfp_LOAGRep_LOAGRep sem)
afp = filter inOutput . ap
ap = map (findWithErr pmpr "building ap") . map2F (ap_LOAGRep_LOAGRep sem)
inss = inss_LOAGRep_LOAGRep sem
gen v = genA A.! v
ain = map (findWithErr nmpr "building an") . map2F (ain_LOAGRep_LOAGRep sem)
asn = map (findWithErr nmpr "building an") . map2F (asn_LOAGRep_LOAGRep sem)
inOutput = not . inContext
inContext f = (f1 == "lhs" && d1 == Inh || f1 /= "lhs" && d1 == Syn)
where (MyOccurrence (_,f1) (_,d1)) = pmp Map.! f
de = [ e | p <- ps, e <- dpe p ]
dpe p = [ (findWithErr pmpr "building dpe" a, b)
| b <- ap p, a <- Set.toList $ sfp (findWithErr pmp "fetching sfp" b) ]
ps = ps_LOAGRep_LOAGRep sem
bounds_p = if Map.null pmp then (0,-1)
else (fst $ Map.findMin pmp, fst $ Map.findMax pmp)
bounds_s = if Map.null nmp then (0,-1)
else (fst $ Map.findMin nmp, fst $ Map.findMax nmp)
toNt :: Nonterminal -> Nt
toNt (Nonterminal ntid _ _ _ prods) = Nt nt dpf dpt
(addD Inh $ ain ty) (addD Syn $ asn ty) (map (toPr ty) prods)
where nt = getName ntid
ty = TyData nt
dpt = [ (as, ai) | ai <- ain ty
, as <- nub$ [ gen s |
i <- inss A.! ai
, s <- map (pmpr Map.!) $
Set.toList (sfp $ pmp Map.! i)
, siblings (s,i)]]
dpf = [ (ai, as) | as <- asn ty
, ai <- nub$ [ gen i |
s <- inss A.! as
, i <- map (pmpr Map.!) $
Set.toList (sfp $ pmp Map.! s)
, siblings (i,s)]]
addD d = map (\i -> (i,inss A.! i,d))
toPr :: MyType -> Production -> Pr
toPr ty (Production con _ _ _ _ _ _) =
Pr p dpp fc_occs (map toFd $ fsInP p)
where p = (ty, getName con)
dpp = [ (f',t)
| t <- afp p, f <- (Set.toList $ sfp (pmp Map.! t))
, let f' = pmpr Map.! f
, not (siblings (f',t))]
fc_occs = foldl' match [] fss
where fss = fsInP p
match s fs = [ ready (inp, out) lhs | inp <- Set.toList inhs
, out <- Set.toList syns] ++ s
where ((inhs, syns), lhs)
| (snd fs) /= "lhs" =
(swap (fieldM Map.! fs),False)
| otherwise = (fieldM Map.! fs, True)
ready e@(f,t) b = (e', genEdge e', b)
where e' = (pmpr Map.! f, pmpr Map.! t)
toFd :: (PLabel, FLabel) -> Fd
toFd fs@((TyData ty, pr), fd) = Fd fd ty inhs syns
where (is,ss) = fieldM Map.! fs
inhs = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList is
syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss
}