{-# Language TypeSynonymInstances,FlexibleInstances,MultiParamTypeClasses,FunctionalDependencies,RankNTypes,FlexibleContexts,KindSignatures,ScopedTypeVariables #-} module Normalization where import Control.Monad.State import Data.Maybe import Data.List import Numeric (showHex) import Debug.Trace import Spec import ASTData import Analysis (dependencyC, topologicalSort) import TypeChecker (typing, unify, apply, buildVertCompEnv, buildProgEnv, typing2', typeCheck) import Inlining (runInlining) import AggregatorExtraction (aggExtraction, aggExtractionE) import TypeInstantiation (runTypeInstantiation) import DependencySimple (computeDependency) import VCOutputNormalization (normalizeVertCompRecordOutputExp, normalizeVertCompRecordOutputExp') {- Big-step normalization. See ICFP paper. We can make a small-step normalization (by fusion/tupling/...), but leads to inefficient code (or difficult-to-be-optimized code). This module drives all compilation steps except for code generation: normalizationAll . The interface to code generators is the data structure named DNormalized. -} {- ********************** Normalized Fregel Code ********************** A single 'fregel' computation that executes a vertex-computation function (ft_Pi) according to the current 'phase' (i). n_fregel NData initPhase [(ft_P1), ..., (ft_Pk)] next stay g The parameters (types and vertex-computation functions): data Phase = P1 | P2 | ... | Pk # unique names of the phases data NData = NData { phase::Maybe Phase, -- the current phase step::Int, -- the number of steps in the current phase data_P1::Pair Bool Data_Pi, -- the pair of end-flag and data for phase P1 ..., -- and so on data_Pk::Pair Bool Data_Pi, step_X1::Int, -- the number of iterations in the first giter ..., -- and so on step_Xl::Int } ft_Pi v prev curr :: Pair Bool Data_Pi -- vertex-computation function for phase Pi built by composing the initialization func., step funct. and termination judgement func. of the phase. initPhase :: Phase -- the initial phase next :: Phase -> Phase -- returns the phase to be executed after the given phase terminates stay :: Phase -> Phase -- returns the phase to be executed when the given phase continues -- stay p = p for most phases, -- but for giter phases stay p is the first phase of its internal ones Implementation: It executes a vertex-computation function (ft_Pi) according to the current 'phase' (i). If the termination condition for the current phase is satisfied, then it proceeds to the next phase. n_fregel NData initPhase [(ft_P1), ..., (ft_Pk)] next stay g = let ft v prev curr = let d1 = if prev v.^phase == Just P1 then ft_P1 v prev curr else prev v.^data_P1 ... dk = if prev v.^phase == Just Pk then ft_Pk v prev curr else prev v.^data_Pk p_end = if prev v.^phase == Just P1 then curr v.^data_P1.^_fst else if prev v.^phase == Just P2 then curr v.^data_P2.^_fst else ... else if prev v.^phase == Just Pk then curr v.^data_Pk.^_fst else False step' = if6 not (prev v.^phase == Nothing) && prev v.^phase == curr v.^phase then prev v.^step + 1 else 0 phase' = if p_end then next (prev v.^phase) else stay (prev v.^phase) step_X1' = if prev v.^phase == Just X1 then if not p_end then prev v.^step_X1 + 1 else 0 else prev v.^step_X1 ... step_Xl' = if prev v.^phase == Just Xl then if not p_end then prev v.^step_Xl + 1 else 0 else prev v.^step_Xl in NData phase' step' d1 ... dk step_X1' ... step_Xl' f0 v = NData (Just initPhase) 0 _ ... _ in fregel f0 ft Fix g -} {--- data structure for Normalized Code (i.e., phase-transition machine) ---} type DPhaseID = Int type DPhase a = (DPhaseID, String, DDefVertComp a, DDefVertComp a, DDefVertComp a) -- Each phase is represented by ID, label, initialization function, step function, and terminatino judgement function type DPhaseGraph a = [(DPhaseID, [([DField a], DPhaseID)])] -- this is currently used to represent the stay and next functions: [ (p, [([], stay p), ([], next p)]) | p in all_phases ]. In general, this was indended to represent dependencies among phases and the list [DField a] was used to remember the ways of dependencies. data DNormalized a = DNormalized String -- the original program (function) name [DPhaseID] -- giter phases (these will have their own iteration counters) [DRecordSpec a] -- user-defined records (DRecordSpec a, [DPhaseID]) -- NData (vertex data + phase info.) and corresponding phase IDs --TODO: (DRecordSpec a, [DPhaseID], DPhaseID) -- NData (vertex data + phase info.) and corresponding phase IDs and the phase of the final result (>=0 or -1 for N.A.) [DPhase a] -- all phases (DPhaseGraph a) -- dependencies among phases (currently, stay and next funcs.) [DPhaseID] -- the initial phases (currently, only one) [DSmplDef a] -- global definitions (such as constants) deriving (Eq, Show) -- the big-step normalization to build data representing the n_fregel program. makeNormalizedData :: (DProgramSpec DASTData, DUnique) -> DNormalized DASTData makeNormalizedData (p, uid) = let s = runExtractGV (p, uid) (DProgramSpec rs (DProg f defs _ _) a) = p fn = getName f daNew = DASTData (newDataType fn) [] c = (DConstructor (newDataTypeName fn) daNew) daInt = (DASTData typeDTInt []) phaseSystemData = [(DField (fieldPhase fn) daInt, DTInt daInt), (DField (fieldStep fn) daInt, DTInt daInt)] iterCounters = map (\n -> (DField (mkStep n) daInt, DTInt daInt)) (iters s) sortWithCurr' = sortWithCurr (map extractFields rs) mkPhase (i::Int, (n, t, _, _, (f1, f2, f3))) = let phaseDataFieldName = mkField n in (i, n, sortWithCurr' [phaseDataFieldName, "_snd"] f1, sortWithCurr' [phaseDataFieldName, "_snd"] f2, sortWithCurr' [phaseDataFieldName, "_fst"] f3) graphVarsWithIds = zip [0..] (reverse $ head $ vars s) -- this assigns phase IDs phases = map mkPhase graphVarsWithIds fsWithIds = map (\(pid, (n, t, _, _, _)) -> let da = (DASTData t []) in ((DField (mkField n) da, buildTypeAST (typePair [typeDTBool, t])), pid)) graphVarsWithIds newDataFiledsWithIds = map (\x -> (x, -1)) phaseSystemData++fsWithIds++map (\x -> (x, -1)) iterCounters fs = map fst newDataFiledsWithIds -- fields of NData ps = map snd newDataFiledsWithIds -- phase ID of each field in NData newData = DRecordSpec c fs daNew idmap = map (\(i::Int, n::DVarName, _, _, _) -> (n, i)) phases lookupId nm = let (Just i) = lookup nm idmap in i initPhase = lookupId (maybe (error "something wrong") (\a -> a) $ initVar s) defs' = map (\(DGDefSmpl def _) -> def) $ filter (isSmplDef) defs deps = map (\(v, _, n, s, _) -> (lookupId v, [([], lookupId s)] ++ if n == "" then [] else [([], lookupId n)])) (reverse $ head $ vars s) is = map (\g -> lookupId g) $ iters s in DNormalized fn is rs (newData, ps) phases deps [initPhase] defs' -- misc functions for the big-step normalizer extractFields :: DRecordSpec a -> (String, [String]) extractFields (DRecordSpec (DConstructor c _) fts _) = (c, map (\(DField f _, _) -> f) fts) buildTypeAST (t@(DTypeTerm "Int" [])) = DTInt (DASTData t []) buildTypeAST (t@(DTypeTerm "Bool" [])) = DTBool (DASTData t []) buildTypeAST (t@(DTypeTerm "String" [])) = DTString (DASTData t []) buildTypeAST (t@(DTypeTerm "Double" [])) = DTDouble (DASTData t []) buildTypeAST (t@(DTypeTerm "(,)" ts)) = DTTuple (map buildTypeAST ts) (DASTData t []) buildTypeAST (t@(DTypeTerm c ts)) = DTRecord (DConstructor c (DASTData t [])) (map buildTypeAST ts) (DASTData t []) buildTypeAST (t) = error ("Unknown situation in buildTypeAST: " ++ show t) isSmplDef (DGDefSmpl def a) = True isSmplDef _ = False newDataTypeName fn = "NData_"++ fn fieldPhase fn = "phase_"++fn fieldStep fn = "step_"++fn newDataType fn = typeSolid (newDataTypeName fn) mkField gx = "data_"++gx mkStep gx = "step_"++gx findInputGraphType (DProgramSpec _ p _) = let (DTypeTerm _ (igt:_)) = typeOf (getData p) in igt getRecordsSpecs = do s <- get return (recordsSpecs s) -- extracting graph variables to collect information to build the phase-transition machine runExtractGV ((p@(DProgramSpec rs (DProg f defs e af) a)), uid) = let igt = (findInputGraphType p) (_, s) = runState (extractGV p) (DEnvGV [] [] [] Nothing defs igt [] (getName f) uid rs) in s { groundDefs = [] } -- the state: the data collected during the extraction data DEnvGV = DEnvGV { vars :: [Chain], -- a stack of chains under extracting iters :: [DVarName], -- giter labels loops :: [(DVarName, Chain)], -- a graph function = a chain initVar :: Maybe DVarName, -- the entry point (initial phase) groundDefs::[DGroundDef DASTData], -- static: definitions of graph functions (used to lookup their input graph names) inputGraphType::DTypeInfo, -- static: the input graph type (of the whole computation) typeInfoOf :: [(DVarName, DTypeInfo)], -- types of labels found so far theProgName :: DVarName, -- static: the program name uniqId :: Int, -- uniq id... recordsSpecs :: [DRecordSpec DASTData] -- record specs. } deriving (Eq) instance (Show DEnvGV) where show (DEnvGV vs is _ iv _ igt tis fn uid rs) = unlines (["Program: " ++ fn] ++ vss++[iterss, ivs, igts, tiss]) where iterss = "iters = " ++ show is ivs = "initVar = " ++ show iv tiss = "Types = " ++ prettyShow tis ++ " --EndOfTypes" igts = "inputGraphType = " ++ show igt vss = concatMap showVars (concat vs) showVars (v, t, n, s, (fi, ft, fp)) = ["Phase: " ++ v, "Type: " ++ prettyShow t, "Next: " ++ n, "Stay: " ++ s] ++ ppDefVertComp fi ++ ppDefVertComp ft ++ ppDefVertComp fp -- the triplet for a phase: initilization, step and judgement functions type PhaseFunctions = (DDefVertComp DASTData, DDefVertComp DASTData, DDefVertComp DASTData) -- list of (phase label (= graph var. name), type, next, stay, the triplet) -- a chain = a graph function type Chain = [(DVarName, DTypeInfo, DVarName, DVarName, PhaseFunctions)] nameOf (v, t, n, s, fs) = v -- accessors to the state setProgName fn = do env <- get put (env {theProgName = fn}) getProgName = do env <- get return (theProgName env) getUid :: State DEnvGV DUnique getUid = do env <- get return (uniqId env) setUid uid = do env <- get put (env { uniqId = uid }) getInputGraphType :: State DEnvGV DTypeInfo getInputGraphType = do env <- get return (inputGraphType env) -- update the next phase of the head of the given chain to the given var updateHead v' [] = [] updateHead v' ((v, t, n, s, fs):xs) = (v, t, v', s, fs):xs getDefs :: State DEnvGV [DGroundDef DASTData] getDefs = do env <- get return (groundDefs env) addTypeInfo v t = do env <- get put (env {typeInfoOf = (v, t):(typeInfoOf env)}) -- adds a new var to the current chain addVar v = addVar' v (getName v) addVar' :: DVar DASTData -> String -> PhaseFunctions -> State DEnvGV () addVar' v stay fs = do env <- get let vs = head $ vars env vss = tail $ vars env types = typeInfoOf env label = getName v theType = getVertexType (typeOf (getData v)) env' = env { vars = (([(label, theType, "", stay, fs)] ++ updateHead (getName v) vs) : vss), typeInfoOf = (label, theType) :types } if length (vars env') == 1 && initVar env' == Nothing then put (env' { initVar = Just (getName v) } ) else put env' -- starts a new chain of graph vars newVarChain :: State DEnvGV () newVarChain = do env <- get put ( env { vars = []:vars env } ) -- pops the current chain popVarChain :: State DEnvGV Chain popVarChain = do env <- get put (env { vars = tail (vars env) }) return (head $ vars env) -- save a chain to be used later to make a loop by iter saveChain :: DFun DASTData -> Chain -> State DEnvGV () saveChain f chain = do env <- get put (env { loops = (getName f, chain) : loops env }) -- remove the chain indexed by f removeChain :: DFun DASTData -> State DEnvGV () removeChain f = do env <- get put (env { loops = filter (\(n, _) -> not (n == getName f)) (loops env)}) -- find the chain indexed by f findChain :: DFun DASTData -> State DEnvGV Chain findChain f = do env <- get case lookup (getName f) (loops env) of Nothing -> error "something wrong with dependency info.?" Just chain -> do removeChain f --single use return chain -- combination of find/remove popChain :: DFun DASTData -> State DEnvGV Chain popChain f = do chain <- findChain f removeChain f return chain -- replacing the argument graph name of a graph function (a chain) with the actual input graph name replaceInputGraphName gi gx (v, t, n, s, (f0, ft, fj)) = let f0' = repVC f0 ft' = repVC ft fj' = repVC fj --TODO: update dep repVC (DDefVertComp f defs e a) = let defs' = map repD defs e' = rec e in DDefVertComp f defs' e' a repD (DDefVar v [] e a) = let e' = rec e in DDefVar v [] e' a repD (DDefTuple vs [] e a) = let e' = rec e in DDefTuple vs [] e' a in (v, t, n, s, (f0', ft', fj')) where rec (DIf p t e a) = let p' = rec p t' = rec t e' = rec e in (DIf p' t' e' a) rec (DTuple es a) = let es' = map rec es in (DTuple es' a) rec (DFunAp f es a) = let es' = map rec es in (DFunAp f es' a) rec (DConsAp c es a) = let es' = map rec es in (DConsAp c es' a) rec ((DFieldAcc t fs a)) = let fs' = map repF fs in DFieldAcc t fs' a rec (x@(DFieldAccE e fs a)) = x rec (DAggr a' e g es a) = let e' = rec e es' = map rec es in (DAggr a' e' g es' a) rec (x@(DVExp (DVar v av) a)) = x rec (x@(DCExp c a)) = x repF (DField f a) = DField (if f == f_gi then f_gx else f) a f_gi = mkField gi f_gx = mkField gx -- for iter-label v, closing the chain of f and adding the label as the last in the current chain addClosedChain v f e types = do chain <- popChain f defs <- getDefs let chain' = updateHead (getName v) chain (Just (DGDefGF (DDefGraphFun _ gi _ _ _) _)) = lookupBy getName (getName f) defs chain'' = map (replaceInputGraphName (getName gi) (getName v)) chain env <- get let vs = head $ vars env vss = tail $ vars env startOfChain = nameOf $ last chain'' env' = env { vars = (chain'' ++ updateHead (getName v) vs) : vss } -- add the chain put env' fn <- getProgName fs <- (buildFunctions fn e v types defs) addVar' v startOfChain fs -- adds an iter label addIter v = do env <- get let env' = env { iters = getName v : iters env } put env' getTypeInfo :: State DEnvGV [(DVarName, DTypeInfo)] getTypeInfo = do env <- get return (typeInfoOf env) -- visitor to extract graph variables (build chains) class GraphVarExtractable a where extractGV :: a -> State DEnvGV () instance GraphVarExtractable (DProgramSpec DASTData) where extractGV (DProgramSpec rs p a) = extractGV p instance GraphVarExtractable (DProg DASTData) where extractGV (DProg f defs e a) = do newVarChain mapM_ extractGV defs instance GraphVarExtractable (DGroundDef DASTData) where extractGV (DGDefVC d a) = return () extractGV (DGDefVI d a) = return () extractGV (DGDefSmpl d a) = return () extractGV (DGDefGV d a) = extractGV d extractGV (DGDefGF d a) = extractGV d instance GraphVarExtractable (DDefGraphVar DASTData) where extractGV (DDefGraphVar v e a) = do types' <- getTypeInfo let types = types' ++ [(getName v, getVertexType (typeOf a))] --trace (getName v ++ "is being processed with types = "++show types) $ case e of (DGIter f0 ft x g _) -> do addClosedChain v ft e types addIter v otherwise -> do defs <- getDefs fn <- getProgName fs <- (buildFunctions fn e v types defs) addVar v fs ------------------- substitutions to build the triplet ------------------ -- for ft/f0 sigma fn go gi types typeVofG typeEofG = recToFieldAcc replace where replace (DFieldAcc (x@(DPrev v av)) fs a) = let (av', fs') = addField go fs a av types fn v' = setData ((getData v) { typeOf = typeGraph [typeVofG, typeEofG]}) v in DFieldAcc (DPrev v' av') fs' a replace (DFieldAcc (x@(DCurr v av)) fs a) = let (av', fs') = addField go fs a av types fn v' = setData ((getData v) { typeOf = typeGraph [typeVofG, typeEofG]}) v in DFieldAcc (DCurr v' av') fs' a replace (y@(DFieldAcc (x@(DVal v av)) fs a)) = if gi == "g" then y else let (av', fs') = addField gi fs a av types fn in DFieldAcc (DPrev v av') fs' a -- for ft/f0 with gzip-elimination optimization: field accessors will be replaced. sigmaZ gez fn go types typeVofG typeEofG = recToFieldAcc replace where replace (DFieldAcc (x@(DPrev v av)) fs a) = let (av', fs') = addField go fs a av types fn v' = setData ((getData v) { typeOf = typeGraph [typeVofG, typeEofG]}) v in DFieldAcc (DPrev v' av') fs' a replace (DFieldAcc (x@(DCurr v av)) fs a) = let (av', fs') = addField go fs a av types fn v' = setData ((getData v) { typeOf = typeGraph [typeVofG, typeEofG]}) v in DFieldAcc (DCurr v' av') fs' a replace (y@(DFieldAcc (x@(DVal v av)) fs a)) = case isIncompleteAccess fs gez of Nothing -> addFieldZ gez fs a av types fn v Just rest -> buildPairExpression v rest -- needs to build a pair locally here. buildPairExpression v (DGVar gv a) = let tv = getVertexType (typeOf a) dummy = DASTData tv [] (av', fs') = addField (getName gv) [] dummy dummy types fn in DFieldAcc (DPrev v av') fs' (DASTData tv []) -- TODO: add dependency data... buildPairExpression v (DGZip ge1 ge2 a) = let pe1 = buildPairExpression v ge1 pe2 = buildPairExpression v ge2 t1 = getVertexType (getType ge1) t2 = getVertexType (getType ge2) pt = typePair [t1, t2] a' = DASTData pt [] -- TODO: add dependency data... ac = DASTData (typeFunction [t1, t2, pt]) [] in expConstructor' "Pair" [pe1, pe2] ac a' isIncompleteAccess [] (gez@(DGZip _ _ _)) = Just gez --needs to build a pair locally! isIncompleteAccess [] _ = Nothing isIncompleteAccess (f:fs) (ge@(DGZip ge1 ge2 a)) = case f of DField "_fst" _ -> isIncompleteAccess fs ge1 DField "_snd" _ -> isIncompleteAccess fs ge2 otherwise -> error ("why " ++ show f ++ " to access " ++ show ge) isIncompleteAccess (f:fs) _ = Nothing -- for Until (\g- > e) sigma' fn gx types typeVofG typeEofG = recToFieldAcc replace where replace (y@(DFieldAcc (x@(DVal v av)) fs a)) = let (av', fs') = addField gx fs a av types fn in DFieldAcc (DCurr v av') fs' a addField gx fs a av types fn = (av', fs') where t2 = typePair [typeDTBool, t1] t1 = case lookup gx types of (Just x) -> x; Nothing -> error ("why? " ++ gx ++ " is not found in " ++ show types) a2 = a { typeOf = t2 } a1 = a { typeOf = t1 } fs' = [ DField (mkField gx) a2 , DField "_snd" a1 ] ++ fs av' = av { typeOf = newDataType fn } addFieldZ gez fs0 a av types fn v = DFieldAcc (DPrev v av') fs' a where (fs, gx) = downToGVar fs0 gez t2 = typePair [typeDTBool, t1] t1 = case lookup gx types of (Just x) -> x; Nothing -> error ("why? " ++ gx ++ " is not found in " ++ show types) a2 = a { typeOf = t2 } a1 = a { typeOf = t1 } fs' = [ DField (mkField gx) a2 , DField "_snd" a1 ] ++ fs av' = av { typeOf = newDataType fn } downToGVar fs (DGVar gx a) = (fs, getName gx) downToGVar (f:fs) (DGZip ge1 ge2 a) = case f of DField "_fst" _ -> downToGVar fs ge1 DField "_snd" _ -> downToGVar fs ge2 recToFieldAcc replace = rec where rec (DIf p t e a) = let p' = rec p t' = rec t e' = rec e in (DIf p' t' e' a) rec (DTuple es a) = let es' = map rec es in (DTuple es' a) rec (DFunAp f es a) = let es' = map rec es in (DFunAp f es' a) rec (DConsAp c es a) = let es' = map rec es in (DConsAp c es' a) rec (x@(DFieldAcc t fs a)) = replace x rec (x@(DFieldAccE e fs a)) = x rec (DAggr a' e g es a) = let e' = rec e es' = map rec es in (DAggr a' e' g es' a) rec (x@(DVExp v a)) = x rec (x@(DCExp c a)) = x applySigma s (DDefVertComp f defs e a) typeVofG typeEofG = let defs' = map (applySigmaD s) defs e' = s e a' = a -- TODO: type has to be changed because of the change of curr/prev's types f' = setData a' f in (DDefVertComp f' defs' e' a') applySigmaD s (x@(DDefVar v [] e a)) = DDefVar v [] (s e) a -- the type is kept during the rewriting applySigmaD s (x@(DDefTuple vs [] e a)) = DDefTuple vs [] (s e) a -- the type is kept during the rewriting delDefs (DDefVertComp f _ e a) = DDefVertComp f [] e a -- TODO: correct VertComp' type according to the output type of prev/curr? -------- the triplet builders ---------------------- -- building (the initial function, the step function, the judgement function) for a given graph exrepssion buildFunctions :: DVarName -> DGraphExpr DASTData -> DVar DASTData -> [(DVarName, DTypeInfo)] -> [DGroundDef DASTData] -> State DEnvGV PhaseFunctions -- assumption: the argument is GDVar buildFunctions fn (ge@(DPregel f0 ft x (DGVar g _) af)) v types defs = case x of (DTermF _) -> buildFunctionsPregel buildDefsBodyFp fn f0 ft g v types defs (DTermI e _) -> buildFunctionsPregel (buildDefsBodyIp e) fn f0 ft g v types defs (DTermU e _) -> buildFunctionsPregel (buildDefsBodyUp e) fn f0 ft g v types defs -- assumption: the argument is GDVar buildFunctions fn (ge@(DGIter f0 ft x (DGVar g _) af)) v types defs = case x of (DTermF _) -> buildFunctionsIter buildDefsBodyFi fn f0 ft g v types defs (DTermI e _) -> buildFunctionsIter (buildDefsBodyIi e) fn f0 ft g v types defs (DTermU e _) -> buildFunctionsIter (buildDefsBodyUi e) fn f0 ft g v types defs -- assumption: the argument is GDVar buildFunctions fn (ge@(DGMap f0 (DGVar g _) af)) v types defs = do gt <- getInputGraphType let typeVofG = getVertexType gt typeEofG = getEdgeType gt label = getName v theType = lookupType label types s = sigma fn label (getName g) types typeVofG typeEofG f0' = let (Just (DGDefVI (DDefVertInit f defs' e af) a)) = lookupBy getName (getName f0) defs in DDefVertComp f defs' e af body = expBool True -- phase-termination = always true xx <- typingForBuildFunctions typeVofG typeEofG theType fn [body] [] [] let [body'] = xx [fj'] = buildDefVCtyped typeVofG typeEofG theType label [("_judge", typeDTBool, [], body')] f0'' <- normalizeVertCompRecordOutputExp'' f0' return (applySigma s f0'' typeVofG typeEofG, applySigma s (delDefs f0'') typeVofG typeEofG {- this is dummy data, removing inner defs to avoid name conflicts -}, fj') -- assumption: the argument is nested gzips! buildFunctions fn (ge@(DGMap f0 gez af)) v types defs = do gt <- getInputGraphType let typeVofG = getVertexType gt typeEofG = getEdgeType gt label = getName v theType = lookupType label types -- here, we need better sigma that replaces (_fst|_snd)* with suitable counterparts in gez s = sigmaZ gez fn label types typeVofG typeEofG f0' = let (Just (DGDefVI (DDefVertInit f defs' e af) a)) = lookupBy getName (getName f0) defs in DDefVertComp f defs' e af body = expBool True -- phase-termination = always true xx <- typingForBuildFunctions typeVofG typeEofG theType fn [body] [] [] let [body'] = xx [fj'] = buildDefVCtyped typeVofG typeEofG theType label [("_judge", typeDTBool, [], body')] f0'' <- normalizeVertCompRecordOutputExp'' f0' return (applySigma s f0'' typeVofG typeEofG, applySigma s (delDefs f0'') typeVofG typeEofG {- this is dummy data, removing inner defs to avoid name conflicts -}, fj') -- TODO: implement nested zips... Hmm, the code generator does someting special to gzip case..... pending. -- assumption: the arguments are GDVar buildFunctions fn (ge@(DGZip (DGVar g1 _) (DGVar g2 _) af)) v types defs = do gt <- getInputGraphType let typeVofG = getVertexType gt typeEofG = getEdgeType gt label = getName v label1 = getName g1 label2 = getName g2 theType = lookupType label types typeGV1 = lookupType label1 types typeGV2 = lookupType label2 types -- the function body (pairing the values from g1 and g2) f0body = expConstructor "Pair" [(expFieldAcc "prev" "v" [mkField label1,"_snd"]), (expFieldAcc "prev" "v" [mkField label2,"_snd"])] body = expBool True -- phase-termination = always true xx <- {- trace (prettyShow typeG1 ++ "," ++ prettyShow typeG2) $ -} typingForBuildFunctions typeVofG typeEofG theType fn [f0body, body] [(label, theType), (label1, typeGV1), (label2, typeGV2)] [] let [f0body', body'] = xx [fj', f0'] = buildDefVCtyped typeVofG typeEofG theType label [("_judge", typeDTBool, [], body'), ("_f0", theType, [], f0body')] f0'' <- normalizeVertCompRecordOutputExp'' f0' -- Hmm.. using f0'' here causes an error in NtoPregel.hs return (f0', delDefs f0' {- this is dummy data, removing inner defs to avoid name conflicts -}, fj') buildFunctions fn (ge@(DGVar g af)) v types defs = do gt <- getInputGraphType let typeVofG = getVertexType gt typeEofG = getEdgeType gt label = getName v label1 = getName g theType = lookupType label types typeG1 = lookupType label1 types -- the function body (copying the value from g) f0body = (expFieldAcc "prev" "v" [mkField label1,"_snd"]) body = expBool True -- phase-termination = always true xx <- typingForBuildFunctions typeVofG typeEofG theType fn [f0body, body] [(label, theType)] [fieldStep fn] let [f0body', body'] = xx [fj', f0'] = buildDefVCtyped typeVofG typeEofG theType label [("_judge", typeDTBool, [], body'), ("_f0", theType, [], f0body')] f0'' <- normalizeVertCompRecordOutputExp'' f0' return (f0'', delDefs f0'' {- this is dummy data, removing inner defs to avoid name conflicts -}, fj') -- typing expressions in the given list bs typingForBuildFunctions typeVofG typeEofG theType fn bs lts sls = do let judgeVCEnv = buildJudgeVCEnv typeVofG typeEofG fn lts sls typing b = do b' <- typing2'' (judgeVCEnv) b theType return b' mapM typing bs typing2'' judgeVCEnv ftbody theType = do uid <- getUid let ((ftbody', _), uid') = typing2' (judgeVCEnv) ftbody theType uid setUid uid' return ftbody' -- environment for typing judgment functions and so on. -- lts is a list of labels used and their types, sls is a list of counters buildJudgeVCEnv typeVofG typeEofG fn lts sls = let testResType = newDataType fn extraTB = map (\(l, t) -> (mkField l, typeFunction [testResType, typePair [typeDTBool, t]])) lts ++ map (\sl -> (sl, typeFunction [testResType, typeDTInt])) sls in buildVertCompEnv typeVofG typeEofG (DTypeVar "tX") testResType (extraTB ++ buildProgEnv typeVofG typeEofG initEnv) -- to build functions for giter (termination conditions are dealt with by buildDefsBody) buildFunctionsIter buildDefsBody fn f0 ft g v types defs = do gt <- getInputGraphType let typeVofG = getVertexType gt typeEofG = getEdgeType gt label = getName v -- the output graph of ft gx = case lookupBy getName (getName ft) defs of (Just (DGDefGF (DDefGraphFun _ _ _ (DGVar go _) _) _)) -> go otherwise -> error ("why doesn't ft has this from?") labelX = getName gx s = sigma fn label (getName g) types typeVofG typeEofG f0' = let (Just (DGDefVI (DDefVertInit f defs' e af) a)) = lookupBy getName (getName f0) defs in DDefVertComp f defs' e af theType = lookupType label types theTypeX = lookupType labelX types -- building the body of ft (in the sense of pregel) ftbody = (expFieldAcc "prev" "v" [mkField labelX,"_snd"]) -- copy the output graph judgeVCEnv = buildJudgeVCEnv typeVofG typeEofG fn [(labelX, theTypeX), (label, theType)] [mkStep label] s' = sigma' fn label types typeVofG typeEofG ftbody' <- typing2'' (judgeVCEnv) ftbody theType (defs', body') <- buildDefsBody label judgeVCEnv s' let [fj', ft'] = buildDefVCtyped typeVofG typeEofG theType label [("_judge", typeDTBool, defs', body'), ("_ft", theType, [], ftbody')] -- this has to be ConsApp (to work with the current NtoPregel.hs ) ft'' <- normalizeVertCompRecordOutputExp'' ft' f0'' <- normalizeVertCompRecordOutputExp'' f0' return (applySigma s f0' typeVofG typeEofG, ft'', fj') normalizeVertCompRecordOutputExp'' ft = do uid <- getUid rs <- getRecordsSpecs let (ft', uid') = normalizeVertCompRecordOutputExp' rs ft uid setUid uid' return ft' -- to build functions for fregel (termination conditions are dealt with by buildDefsBody) buildFunctionsPregel buildDefsBody fn f0 ft g v types defs = do gt <- getInputGraphType let typeVofG = getVertexType gt typeEofG = getEdgeType gt label = getName v s = sigma fn label (getName g) types typeVofG typeEofG ft' = let (Just (DGDefVC vc a)) = lookupBy getName (getName ft) defs in vc f0' = let (Just (DGDefVI (DDefVertInit f defs' e af) a)) = lookupBy getName (getName f0) defs in DDefVertComp f defs' e af -- building the enviroment for the VertexCompute being made testResType = newDataType fn theType = lookupType label types judgeVCEnv = buildJudgeVCEnv typeVofG typeEofG fn [(label, theType)] [fieldStep fn] s' = sigma' fn label types typeVofG typeEofG (defs', body') <- buildDefsBody fn label judgeVCEnv s' -- TODO: dependency data? let [fj'] = buildDefVCtyped typeVofG typeEofG theType label [("_judge", typeDTBool, defs', body')] ft'' <- normalizeVertCompRecordOutputExp'' ft' f0'' <- normalizeVertCompRecordOutputExp'' f0' return (applySigma s f0'' typeVofG typeEofG, applySigma s ft'' typeVofG typeEofG, fj') -- for giter: looking the individual counter buildDefsBodyFi label judgeVCEnv = buildDefsBodyF (mkStep label) label judgeVCEnv buildDefsBodyIi e label judgeVCEnv = buildDefsBodyI e (mkStep label) label judgeVCEnv buildDefsBodyUi e label judgeVCEnv = buildDefsBodyU e (mkStep label) label judgeVCEnv -- for fregel: looking the common step counter buildDefsBodyFp fn label judgeVCEnv = buildDefsBodyF (fieldStep fn) label judgeVCEnv buildDefsBodyIp e fn label judgeVCEnv = buildDefsBodyI e (fieldStep fn) label judgeVCEnv buildDefsBodyUp e fn label judgeVCEnv = buildDefsBodyU e (fieldStep fn) label judgeVCEnv -- to build judgment function for Fix -- buildDefsBodyF stepLabel label judgeVCEnv idp vth s = buildDefsBodyF stepLabel label judgeVCEnv s = do let aggV = "agg_"++label aggBody = expAggr "and" (expFieldAcc "prev" "u" [mkField label,"_snd"] ^== expFieldAcc "curr" "u" [mkField label,"_snd"]) "tg" [] body = (((expFieldAcc "prev" "v" [stepLabel]) ^> (expInt 0))) ^&& (expVar aggV) -- body = expCheckTerm aggV -- typing of the aggregator used in the body of VC aggBody' <- typing2'' (judgeVCEnv) aggBody typeDTBool -- typing of the body of VC body' <- typing2'' ([(aggV, typeDTBool)]++judgeVCEnv) body typeDTBool --building the VC let defAgg = DDefVar (DVar aggV (DASTData typeDTBool [])) [] aggBody' (DASTData typeDTBool []) return ([defAgg], body') -- to build judgment function for Iter buildDefsBodyI e stepLabel label judgeVCEnv s = do let iterV = "iter_"++label body = (((expFieldAcc "prev" "v" [stepLabel]) ^== (expVar iterV))) --TODO: step -> step_label -- typing of the body of VC body' <- typing2'' ([(iterV, typeDTInt)]++judgeVCEnv) body typeDTBool --building the VC let defV = DDefVar (DVar iterV (DASTData typeDTInt [])) [] e (DASTData typeDTInt []) return ([defV], body') -- to build judgment function for Until buildDefsBodyU e stepLabel label judgeVCEnv s = do uid <- getUid let e' = s e (e'', defs, uid') = aggExtractionE e' uid setUid uid' return (defs, e'') buildDefVCtyped typeVofG typeEofG theType label ntdbs = let vertType = typeVertex [typeVofG, typeEofG] tblType = typeFunction[typeVertex [(DTypeVar "tY"), typeEofG], theType] vcType = typeFunction [vertType, tblType, tblType, typeDTBool] vcType' = typeFunction [vertType, tblType, tblType, theType] f (n, t, ds, b) = let vcType = typeFunction [vertType, tblType, tblType, t] in defVCtyped (label++n) vcType ds b in map f ntdbs lookupType label types = case lookup label types of (Just x) -> x; Nothing -> error ("why? " ++ label ++ " is not found in " ++ show types) defVCtyped f t ds b = DDefVertComp (DFun f (DASTData t [])) ds b (DASTData t []) instance GraphVarExtractable (DDefGraphFun DASTData) where extractGV (DDefGraphFun f v defs e a) = do newVarChain -- starts a new chain addTypeInfo (getName v) (getVertexType $ typeOf (getData v)) -- add the type info. of the argument mapM_ extractGV defs -- build children's chain chain <- popVarChain -- finish the chain saveChain f chain -- save the chain ------------ topological sort of bindings in DDefVertComp with taking 'curr' into account -------- -- by analyzing which field of curr depends on what name -- shallow analysis: no analysis on subexpressions (fields of records) -- So, the follwoing two programs do the same computation, but -- let ab = Pair 1 (curr v .^ pval .^ _fst) in Dat ab is NG (ab depends on ab); -- let a = 1; b = (curr v .^ pval .^ _fst) in Dat (Pair a b) is OK ( b depends on a ). sortWithCurr :: [(String, [String])] -> [String] -> DDefVertComp DASTData -> DDefVertComp DASTData sortWithCurr fs phaseDataPrefix (x@(DDefVertComp f defs e a)) = res where (defs', ok) = topologicalSort (zip3 [0..] deps defs) names = map getNames defs deps = map (genDeps (names, rdeps, phaseDataPrefix)) defs rdeps = genRecordDeps' fs names e res = if ok then DDefVertComp f (map snd defs') e a else error ("circular dependency through curr!\n" ++ unlines (ppDefVertComp x)) genRecordDeps :: [DRecordSpec a] -> [[String]] -> DExpr DASTData -> [([String], [Int])] genRecordDeps rs ns e = genRecordDeps' (("Pair", ["_fst", "_snd"]):map extractFields rs) ns e --union x y = nub (x++y) unions = foldr union [] flatDeps depss = [([], unions (concatMap (map snd) depss))] addDeps deps = map (\(fs, ds) -> (fs, union ds deps)) mergeRDs dt de = union dt de -- correct? genRecordDeps' :: [(String, [String])] -> [[String]] -> DExpr DASTData -> [([String], [Int])] genRecordDeps' fs ns e = let ret = rec e in {- trace (show ret) $ -} ret where rec (DIf p t e _) = let [([], deps)] = rec p dt = rec t de = rec e dte = mergeRDs dt de in addDeps deps dte -- adding the condition's deps rec (DTuple es _) = flatDeps $ map rec es -- conservative: flatterns the dependencies rec (DFunAp f es _) = addDeps (findIndex2 ns (getName f)) $ flatDeps $ map rec es -- conservative: flatterns the dependencies rec (DConsAp (DConstructor c _) es _) = let Just flds = lookup c fs des = map rec es in concat $ zipWith (\field de -> map (\(fields, deps) -> (field:fields, deps)) de) flds des -- adding the fields of the record rec (DFieldAcc (DCurr _ a) fs _) = error "Do not use curr in the last expression of VertexCmopute" rec (DFieldAcc _ _ _) = [] rec (DFieldAccE _ _ _) = [] rec (DAggr _ e _ es _) = flatDeps $ map rec (e:es) -- conservative: flatterns the dependencies rec (DVExp v _) = [([], findIndex2 ns (getName v))] rec (DCExp _ _) = [] class GenDepsable a where genDeps :: ([[String]], [([String], [Int])], [String]) -> a -> [Int] getRdeps (_, rdeps, _) = rdeps getENames (names, _, _) = names getPDP (_, _, pdp) = pdp instance (GenDepsable (DSmplDef a)) where genDeps env (DDefFun _ _ [] e _) = genDeps env e genDeps env (DDefVar _ [] e _) = genDeps env e genDeps env (DDefTuple _ [] e _) = genDeps env e genDepss env = foldr (\a r -> nub (genDeps env a ++ r)) [] instance (GenDepsable (DExpr a)) where genDeps env (DIf p t e _) = nub (genDeps env p ++ (nub (genDeps env t ++ genDeps env e))) genDeps env (DTuple es _) = genDepss env es genDeps env (DFunAp f es _) = nub (genDeps env f ++ genDepss env es) genDeps env (DConsAp _ es _) = (genDepss env es) genDeps env (DFieldAcc (DCurr _ a) fs _) = let f1:f2:sfs = map getName fs -- if [f1, f2] is of the fields that were added during the normalization process to indicate the phase, we have to add dependency. otherwise, no need to add dependency because the order of computation is guaranteed outside the VertexCompute being processed. rdeps = getRdeps env res = findIndex (\(sfs', _) -> isPrefixOf sfs' sfs) rdeps in if [f1, f2] == (getPDP env) then case res of Just i -> snd (rdeps!!i) Nothing -> error ("Something wrong! not found " ++ show sfs ++ " in " ++ show rdeps) else [] -- add dependency of the field in the result genDeps env (DFieldAcc _ _ _) = [] genDeps env (DFieldAccE _ _ _) = [] genDeps env (DAggr _ e _ es _) = (genDepss env (e:es)) genDeps env (DVExp v _) = genDeps env v genDeps env (DCExp _ _) = [] instance (GenDepsable (DVar a)) where genDeps env (DVar v _) = findIndex2 (getENames env) v findIndex2 names v = maybe [] (\i -> [i]) (findIndex (\ns -> maybe False (const True) (findIndex (==v) ns)) names) instance (GenDepsable (DFun a)) where genDeps env (DFun f _) = findIndex2 (getENames env) f genDeps env (DBinOp f _) = findIndex2 (getENames env) f ------------------------- driver ------------------------ -- this executes the big-step normalization as well as typechecking and the other transformations normalizationAll ::Show a => DProgramSpec a -> DNormalized DASTData normalizationAll p = makeNormalizedData (normalization p defaultOpt) normalizationAll' ::Show a => DProgramSpec a -> Option -> DNormalized DASTData normalizationAll' p ops = makeNormalizedData (normalization p ops) -- compilation (typechecking and normalization) chain run on the AST normalization :: Show a => DProgramSpec a -> Option -> (DProgramSpec DASTData, DUnique) normalization ast ops = normalizationX numNormStages ast ops -- TODO: K-normlization for graph expressions (at an early stage). currently, the parser does reject. numNormStages = 11 normalizationX :: Show a => Int -> DProgramSpec a -> Option -> (DProgramSpec DASTData, DUnique) normalizationX n ast0 ops = let uid0 = 1024 (ast1, uid1) = dependencyC uid0 ast0 -- 1. alpha renaming to unique names, topological sort by dependencies ast2 = typing ast1 -- 2. typechecking ast3 = mapData (\(t,(d,_)) -> DASTData t d) ast2 -- 3. restructuring aux. data in the AST (ast4, uid4) = runInlining ast3 uid1 -- 4. inlining functions (dependency info. is broken here to make the process simple) (ast5, uid5) = aggExtraction ast4 uid4 -- 5. extraction of aggregation expressions ast6 = fixInputGraphType ast5 -- 6. fix the type of input graph (ast7, uid7) = runTypeInstantiation ast6 uid5 -- 7. instantiating polymorphic funcs. (ast8, uid8) = makeOutputGraphVar ast7 uid7 -- 8. make the output expression to be a graph variable (ast9, uid9) = normalizeVertCompRecordOutputExp ast8 uid8 -- 9. make the output expression of a vertex computation function to be a simple constructor application astA = computeDependency ast9 -- 10. updating the dependency info. astB = if zipOpt ops then moveGZipsToGMaps astA -- 11. moving gzips into gmaps (and gzips) else astA in ([ast3, ast4, ast5, ast6, ast7, ast8, ast9, astA, astB]!!(n-3), uid9) -- moving gzips to gmaps so to remove redundant intermediate data about pairing -- if g = gzip g1 g2 is used only inside a gmap, expand it. -- assumption: the last expression is a graph variable -- assumption: k-normalization about graph expressions moveGZipsToGMaps :: DProgramSpec DASTData -> DProgramSpec DASTData moveGZipsToGMaps (DProgramSpec rs (DProg f defs e app) ap) = let (dgfs, dgvs, ds) = splitGDefs defs ginType = getInputType $ getType f g = DVar "g" (DASTData (ginType) []) -- the input is 'g' dgvs' = map (\dgv -> DGDefGV dgv (getData dgv)) $ moveZM g (map (\(DGDefGV dgv a) -> dgv) dgvs) -- moving in the outermost level dgfs' = map moveZMinGF dgfs -- moving in other graph functions defs' = ds ++ dgfs' ++ dgvs' in DProgramSpec rs (DProg f defs' e app) ap -- wrapper for moveZM moveZMinGF (DGDefGF (DDefGraphFun f gin dgvs e a) ap) = let dgvs' = moveZM gin dgvs in DGDefGF (DDefGraphFun f gin dgvs' e a) ap -- moving single-use gzips inside gmaps -- gin is the input graph -- gvs is a list of graph variable definitions whose rhss are k-normal (no nested expressions). moveZM :: DVar DASTData -> [DDefGraphVar DASTData] -> [DDefGraphVar DASTData] moveZM gin gvs = run gvs where run [] = [] run (gv:gvs) = case gv of (DDefGraphVar gn (gez@(DGZip ge1 ge2 a)) a') -> let gnn = getName gn gused = filter (isUsed gnn) gvs in if length gused == 1 && isMapOrZip (head gused) then run (map (expandZip gnn gez) gvs) else gv:run gvs otherwise -> gv:run gvs -- replace variable gnn with gez in ge expandZip :: String -> DGraphExpr DASTData -> DDefGraphVar DASTData -> DDefGraphVar DASTData expandZip gnn gez (DDefGraphVar gv ge a) = (DDefGraphVar gv (run ge) a) where run (DPregel fi fs tc ge a) = (DPregel fi fs tc (run ge) a) run (DGMap f ge a) = (DGMap f (run ge) a) run (DGZip ge1 ge2 a) = (DGZip (run ge1) (run ge2) a) run (DGIter fi fs tc ge a) = (DGIter fi fs tc (run ge) a) run (ge@(DGVar (DVar n a) ap)) = if gnn == n then gez else ge isMapOrZip (DDefGraphVar gv (DGMap f ge a) a') = True isMapOrZip (DDefGraphVar gv (DGZip ge1 ge2 a) a') = True isMapOrZip _ = False isUsed gn (DDefGraphVar gv ge a) = isUsed' ge where isUsed' (DPregel fi fs tc ge a) = isUsed' ge isUsed' (DGMap f ge a) = isUsed' ge isUsed' (DGZip ge1 ge2 a) = isUsed' ge1 || isUsed' ge2 isUsed' (DGIter fi fs tc ge a) = isUsed' ge isUsed' (DGVar (DVar n a) ap) = gn == n -- dividing a list of definitions into three kinds: graph functions, graph variables, and others splitGDefs defs = splitGDefs' [] [] [] defs splitGDefs' dgfs dgvs ds [] = (reverse dgfs, reverse dgvs, reverse ds) splitGDefs' dgfs dgvs ds ((d@(DGDefGF _ _)):defs) = splitGDefs' (d:dgfs) dgvs ds defs splitGDefs' dgfs dgvs ds ((d@(DGDefGV _ _)):defs) = splitGDefs' dgfs (d:dgvs) ds defs splitGDefs' dgfs dgvs ds (d:defs) = splitGDefs' dgfs dgvs (d:ds) defs -- make the last expression to be a variable binding a graph (8th step) makeOutputGraphVar :: DProgramSpec DASTData -> DUnique -> (DProgramSpec DASTData, DUnique) makeOutputGraphVar p uid = case p of (DProgramSpec rs (DProg f defs (DGVar _ _) app) ap) -> (p, uid) (DProgramSpec rs (DProg f defs e app) ap) -> let ae = (getData e) (nv, uid') = genNewName uid "g_v" gv = (DVar nv ae) def = DGDefGV (DDefGraphVar gv e ae) ae defs' = defs++[def] e' = DGVar gv ae in (DProgramSpec rs (DProg f defs' e' app) ap, uid') -- fix the input graph type (stupid) (6th step) fixInputGraphType' :: DTypeInfo -> DTypeInfo -> DProgramSpec DASTData -> DProgramSpec DASTData fixInputGraphType' tv te p = let gt = typeGraph [tv, te] pt = getType p pgt = getInputType pt s = unify [(gt, pgt)] p' = mapData (\a -> a {typeOf = apply s (typeOf a)}) p in p' fixInputGraphType :: DProgramSpec DASTData -> DProgramSpec DASTData fixInputGraphType p = let pgt = getInputType (getType p) in case pgt of DTypeTerm "Graph" [DTypeVar _, DTypeVar _] -> fixInputGraphType' typeNull typeNull p DTypeTerm "Graph" [DTypeVar _, et] -> fixInputGraphType' typeNull et p DTypeTerm "Graph" [vt , DTypeVar _] -> fixInputGraphType' vt typeNull p DTypeTerm "Graph" [vt , et ] -> p ------------------------- pretty printer with types ------------------ ppprint = putStrLn . unlines . ppProgramSpec -- without types (; ppprintStr = unlines . ppProgramSpec ppprintStr' n p = (getPName p ++ "__N" ++ show n ++ ".fgl", ppprintStr p) pptprintStr :: PrettyPrinterWithType a => a -> String pptprintStr = unlines . ppt pptprintStr' n p = (getPName p ++ "__N" ++ show n ++ ".tfgl", pptprintStr p) getPName (DProgramSpec rs (DProg f defs _ _) a) = getName f pptprint :: PrettyPrinterWithType a => a -> IO () pptprint = putStrLn . unlines . ppt type Misc = DASTData class PrettyPrinterWithType a where ppt :: a -> [String] instance PrettyPrinterWithType (DProgramSpec Misc) where ppt (DProgramSpec rs p _) = concatMap ppt rs ++ ppt p instance PrettyPrinterWithType (DRecordSpec Misc) where ppt r = ppRecordSpec r instance PrettyPrinterWithType (DProg Misc) where ppt (x@(DProg f ds e _)) = [typeSig f ++ dep x, ppFun f ++ " g = "] ++ rest where rest = if length ds == 0 then indent (ppt e) else indent $ let_in (concat $ insList ";" "" $ map ppt ds) (ppt e) typeSig f = ppFun f ++ "::" ++ prettyShow (getType f) typeSigV v = ppVar v ++ "::" ++ prettyShow (getType v) typeSigC c = ppConst c ++ "::" ++ prettyShow (getType c) typeSigCr c = ppConstructor c ++ "::" ++ prettyShow (getType c) getDepNames x = depOf $ getData x dep x = " -- depends on " ++ ppList "," (getDepNames x) instance PrettyPrinterWithType (DGroundDef Misc) where ppt (DGDefVC d _) = ppt d ppt (DGDefVI d _) = ppt d ppt (DGDefGV d _) = ppt d ppt (DGDefGF d _) = ppt d ppt (DGDefSmpl d _) = ppt d instance PrettyPrinterWithType (DDefVertComp Misc) where ppt (x@(DDefVertComp f ds e _)) = if length ds == 0 then [typeSig f ++ dep x] ++ indentWith (ppFun f ++ " v prev curr = ") (ppt e) else [typeSig f ++ dep x] ++ [ppFun f ++" v prev curr = "] ++ indent (let_in (concat $ insList ";" "" $map ppt ds) (ppt e)) instance PrettyPrinterWithType (DDefVertInit Misc) where ppt (x@(DDefVertInit f ds e _)) = if length ds == 0 then [typeSig f ++ dep x] ++ indentWith (ppFun f ++ " v = ") (ppt e) else [typeSig f ++ dep x] ++ [ppFun f ++" v = "] ++ indent (let_in (concat $ insList ";" "" $map ppt ds) (ppt e)) instance PrettyPrinterWithType (DDefGraphVar Misc) where ppt (x@(DDefGraphVar v e _)) = [typeSigV v ++ dep x] ++ indentWith (ppVar v ++ " = ") (ppt e) instance PrettyPrinterWithType (DDefGraphFun Misc) where ppt (x@(DDefGraphFun f v ds e _)) = if length ds == 0 then header ++ indent (ppt e) else header ++ indent (let_in (concat $ insList ";" "" $ map ppt ds) (ppt e)) where header = [ typeSig f ++ dep x, ppFun f ++ " " ++ (ppVar v) ++ " = " ] instance PrettyPrinterWithType (DGraphExpr Misc) where ppt (x@(DPregel f0 ft t g _)) = ["("++(ppList " " $ ["pregel", ppFun f0, ppFun ft] ++ ppt t ++ ppt g) ++ "::" ++ prettyShow (getType x)++")"] ppt (x@(DGMap f g _)) = ["("++ppList " " (["gmap", ppFun f] ++ ppt g) ++ "::" ++ prettyShow (getType x)++")"] ppt (x@(DGZip g1 g2 _)) = ["("++ppList " " (["gzip"] ++ ppt g1 ++ ppt g2) ++ "::" ++ prettyShow (getType x)++")"] ppt (x@(DGIter f0 ft t g _)) = ["("++(ppList " " $ ["iter", ppFun f0, ppFun ft] ++ ppt t ++ ppt g) ++ "::" ++ prettyShow (getType x)++")"] ppt (x@(DGVar g _)) = ["("++ppVar g ++ "::" ++ prettyShow (getType x)++")"] instance PrettyPrinterWithType (DTermination Misc) where ppt (DTermF _)= ["Fixpoint"] ppt (DTermI e _) = ["(Iter (" ++ ppList " " (ppt e) ++ "))"] ppt (DTermU e _) = ["(Until (\\g->" ++ ppList " " (ppt e) ++ "))"] instance PrettyPrinterWithType (DVar Misc) where ppt x = [ppVar x ++ "::" ++ prettyShow (getType x) ++ dep x] instance PrettyPrinterWithType (DSmplDef Misc) where ppt (x@(DDefFun f vs ds e _)) = if length ds == 0 then header ++ indent (ppt e) else header ++ indent (let_in (concatMap ppt ds) (ppt e)) where header = [typeSig f ++ dep x, ppFun f ++ " " ++ ppList " " (map ppVar vs) ++ " = " ] ppt (x@(DDefVar v ds e _)) = if length ds == 0 then header ++ indent (ppt e) else header ++ indent (let_in (concatMap ppt ds) (ppt e)) where header = [typeSigV v ++ dep x, ppVar v ++ " = "] ppt (x@(DDefTuple vs ds e _)) = if length ds == 0 then header ++ indent (ppt e) else header ++ indent (let_in (concatMap ppt ds) (ppt e)) where header = [tt ++ "::" ++ prettyShow (getType x) ++ dep x, tt ++" = "] tt = "(" ++ ppList ", " (map ppVar vs) ++ ")" enclose' xs = indentWith "(" xs' where xs' = init xs ++ [last xs++")"] addSig x xs = enclose' xs'' where xs' = enclose' xs xs'' = init xs' ++ [last xs'++"::"++ prettyShow (getType x)] instance PrettyPrinterWithType (DExpr Misc) where ppt (x@(DIf c t e _)) = addSig x (indentWith "if " (ppt c) ++ indentWith "then " (ppt t) ++ indentWith "else " (ppt e)) ppt (x@(DVExp v _)) = ["("++typeSigV v++")"] ppt (x@(DCExp c _)) = ["("++typeSigC c++")"] ppt (x@(DFunAp f es _)) = addSig x [ppList " " (ppFun f: map flatE' es)] ppt (x@(DConsAp c es _)) = addSig x [ppList " " (ppConstructor c: map flatE' es)] ppt (x@(DTuple es _)) = addSig x $ indentWith "(" (concat $ insList "," ")" $ map ppt es) ppt (x@(DFieldAcc e fs _)) = addSig x $ [ ppTableExpr e ++ (concat $ map ((".^"++).ppField) fs) ] ppt (x@(DFieldAccE e fs _)) = addSig x $ [ ppEdge e ++ (concat $ map ((".^"++).ppField) fs) ] ppt (x@(DAggr a e g es _)) = addSig x $ [ppAgg a ++ " [ " ++ flatE2' e ++ " | " ++ ppGen g ++ ps ++ " ] "] where ps = if length es == 0 then "" else "," ++ ppList "," (map flatE' es) --ppt e = ppExpr e flatE' :: (PrettyPrinterWithType (DExpr a)) => DExpr a -> String flatE' = {- enclose . -} ppList " " . ppt flatE2' :: (PrettyPrinterWithType (DExpr a)) => DExpr a -> String flatE2' = ppList " " . ppt printN' (DNormalized fn is rs nd ps deps [ip] defs) = putStrLn(unlines $ [ "fname: " ++ fn, "is: " ++ show is, "rs: "] ++ concatMap (indentWith " " . ppRecordSpec) rs ++ indentWith " " (ppRecordSpec (fst nd)) ++ [ "ip: " ++ show ip, "ps: "] ++ concatMap (\(is, str, fi, fs, fj) -> [" id: " ++ show is] ++ [ " nm: " ++ str] ++ indentWith " fi:" (ppDefVertComp fi) ++ indentWith " fs:" (ppDefVertComp fs) ++ indentWith " fj:" (ppDefVertComp fj)) ps ++ ["defs: "] ++ concatMap ppSmplDef defs ) ------------ pretty printer for normalized oen (n_fregel) ---------------- printNStr = unlines . ppN getFName (DNormalized fn is rs nd ps deps [ip] defs) = fn printNStr' p = (getFName p ++ "__N" ++ show (numNormStages - 1) ++ ".fgl", printNStr p) -- using Int indtead of Maybe Phase for simplicity printN = putStrLn . printNStr addSemicolon :: [[String]] -> [[String]] addSemicolon (x:[]) = x:[] addSemicolon (x:xs) = addSemicolonLast x:addSemicolon xs where addSemicolonLast (x:[]) = (x++";"):[] addSemicolonLast (x:xs) = x:addSemicolonLast xs ppN (DNormalized fn is rs' nd ps deps [ip] defs) = let rs = fst nd:rs' (Just theRecord) = lookupBy (\(DRecordSpec c _ _) -> getName c) (newDataTypeName fn) rs in concatMap ppRecordSpec rs ++ [fn ++ " g = "] ++ indent (indentWith "let " (concat $ addSemicolon (map ppSmplDef defs ++ map (genFtX fn is) ps ++ [genFt fn ps is deps theRecord] ++ [genF0 fn ip rs theRecord])) ++ ["in fregel f0 ft Fix g"]) genF0 fn ip rs (DRecordSpec _ (_:_:fts) _) = ["f0 v = " ++ newDataTypeName fn ++" " ++ show ip ++ " 0" ++ concatMap (" "++) (map (genInitData.snd) fts)] where genInitData (DTInt _) = "0" genInitData (DTBool _) = "False" genInitData (DTString _) = "\"\"" genInitData (DTDouble _) = "0.0" genInitData (DTTuple ts _) = "(" ++ ppList ", " (map genInitData ts) ++ ")" genInitData (DTRecord (DConstructor "Pair" _) [t1,t2] _) = "(Pair " ++ genInitData t1 ++ " " ++ genInitData t2 ++ ")" genInitData (DTRecord c ts _) = let (Just (DRecordSpec _ fts _)) = lookupBy (\(DRecordSpec c _ _) -> getName c) (getName c) rs in "(" ++ (getName c) ++ concatMap (" "++) (map (genInitData.snd) fts) ++ ")" genFt fn ps is deps theRecord = ["ft v prev curr = "] ++ indentWith " let " (concat $ addSemicolon (map (genFt0 fn) ps ++ [genEnd fn ps] ++ [genStep fn ps] ++ [genPhase fn ps deps] ++ map (genStepX fn ps) is)) ++ [" in " ++ genFtBody fn ps is theRecord] genFt0 :: DVarName -> (DPhaseID, String, DDefVertComp DASTData, DDefVertComp DASTData, DDefVertComp DASTData) -> [String] genFt0 fn (pid, label, f0, ft, fj) = ppSmplDef $ defVar ("d_"++label) [] (expIf (expFieldAcc "prev" "v" [(fieldPhase fn)] ^== (expInt pid)) (expFun ("ft_"++label) [expVar "v", expVar "prev", expVar "curr"]) (expFieldAcc "prev" "v" [mkField label])) genStepX fn ps pid = ppSmplDef $ defVar ("s_" ++ label) [] (expIf (expFieldAcc "prev" "v" [(fieldPhase fn)] ^== (expInt pid)) (expIf (expFun "not" [expVar "p_end"]) (expBin "+" (expInt 1) (expFieldAcc "prev" "v" [mkStep label])) (expInt 0)) (expFieldAcc "prev" "v" [mkStep label])) where label = lookupLabel pid ps genPhase fn ps deps = concat $ addSemicolon $ map ppSmplDef [defNext, defStay, defPhase] where defStay = defFun "stay" ["pid"] [] (recs 0 deps) defNext = defFun "next" ["pid"] [] (recs 1 deps) recs k [] = expInt (maxpid ps) recs k ((pid, fps):ds) = expIf (expVar "pid" ^== expInt pid) (expInt ((if length fps > k then snd (fps!!k) else maxpid ps))) (recs k ds) defPhase = defVar "phase'" [] (expIf (expVar "p_end") (expFun ("next") [(expFieldAcc "prev" "v" [(fieldPhase fn)])]) (expFun ("stay") [(expFieldAcc "prev" "v" [(fieldPhase fn)])])) genFtBody fn ps is (DRecordSpec _ (_:_:fts) _) = newDataTypeName fn ++ " phase' step'" ++ concatMap (" "++) (map (\(_, label, _,_,_) -> "d_" ++ label) ps) ++ concatMap (" "++) (map (\i -> "s_" ++ lookupLabel i ps) is) lookupLabel i ps = let (Just l) = lookup i (map (\(i,l,_,_,_) -> (i, l)) ps) in l genEnd fn ps = ppSmplDef $ defVar "p_end" [] (genEndrec ps) where genEndrec [] = expBool False genEndrec ((pid, label, f0, ft, fj):ps) = expIf (expFieldAcc "prev" "v" [(fieldPhase fn)] ^== (expInt pid)) (expFieldAcc "curr" "v" [mkField label, "_fst"]) (genEndrec ps) genStep fn ps = ppSmplDef $ defVar "step'" [] (expIf ((expFun "not" [expFieldAcc "prev" "v" [(fieldPhase fn)] ^== (expInt (maxpid ps))]) ^&& (expFieldAcc "prev" "v" [(fieldPhase fn)] ^== expFieldAcc "curr" "v" [(fieldPhase fn)] )) (expBin "+" (expInt 1) (expFieldAcc "prev" "v" [(fieldStep fn)])) (expInt 0)) maxpid ps = 1 + maximum (map (\(pid,_,_,_,_) -> pid) ps) getDefsOfVC (DDefVertComp _ defs _ _) = defs -- omitting type info. genFtX :: DVarName -> [DPhaseID] -> (DPhaseID, String, DDefVertComp DASTData, DDefVertComp DASTData, DDefVertComp DASTData) -> [String] genFtX fn is (pid, label, f0, ft, fj) = let (DDefVertComp _ defs0 e0 _) = mapData (\_ -> "") f0 (DDefVertComp _ defst et _) = mapData (\_ -> "") ft (DDefVertComp _ defsj ej _) = mapData (\_ -> "") fj -- if this is iter, then look at its step counter st = if (elem pid is) then mkStep label else (fieldStep fn) defD = defVar "d" [] (expIf (expFieldAcc "prev" "v" [st] ^== (expInt 0)) e0 et) defEnd = defVar "end" [] ej in ppDefVertComp $ defVertComp ("ft_"++label) (defs0++defst++[defD]++defsj++[defEnd]) (expConstructor "Pair" [(expVar "end"),(expVar "d")]) ---------------- for flatterning nested records (not used yet) ------------------------ genFieldListsOfType :: [DRecordSpec a] -> DTypeInfo -> [([String], DTypeInfo)] genFieldListsOfType rs t = genFieldListsOfType' (buildExpander rs) t genFieldListsOfType' :: (DTypeInfo -> [(String, DTypeInfo)]) -> DTypeInfo -> [([String], DTypeInfo)] genFieldListsOfType' expander t = case (expander t) of [] -> [([], t)] fts -> concatMap f fts where f (field, t) = map (\(fields, t') -> (field:fields, t')) (genFieldListsOfType' expander t) buildExpander :: [DRecordSpec a] -> DTypeInfo -> [(String, DTypeInfo)] buildExpander rs (DTypeTerm tn ts) = if tn == "Pair" then [("_fst", head ts), ("_snd", head (tail ts))] else if isPrimitive tn then [] else case findRecord rs tn of Just fts -> fts Nothing -> error ("something wrong. not found " ++ tn) findRecord [] _ = Nothing findRecord (DRecordSpec (DConstructor c _) fts _:rs) tn = if c == tn then Just (map (\(DField f _, t) -> (f, toTypeInfo t)) fts) else findRecord rs tn toTypeInfo (DTInt _) = typeDTInt toTypeInfo (DTBool _) = typeDTBool toTypeInfo (DTString _) = typeDTString toTypeInfo (DTDouble _) = typeDTDouble