fregel-1.2.0: compiler/ASTData.hs

{-# Language TypeSynonymInstances,FlexibleInstances,MultiParamTypeClasses,FunctionalDependencies,RankNTypes,FlexibleContexts,KindSignatures,ScopedTypeVariables #-}

{-

Defining
  
  - data structure of aux. data on ASTs
  - initial environment

-}

module ASTData where

import Numeric (showHex)
import Spec (DAdditionalData, getData, setData, DRecordSpec (DRecordSpec), DConstructor(DConstructor), PrettyShow (prettyShow), ppList)

-- compilation targets
data TargetSystem = Giraph | PregelPlus | IROnly | NASTOnly | ASTOnly | NoSystem
                    deriving (Eq, Show)

-- compilation option
data Option =
  Option { normLevel :: Int           -- normalization level (1--10)
         , zipOpt :: Bool             -- -oz:  zip-elimination
         , pcFusionOpt :: Bool        -- -opc: prev-curr fusion
         , mzFusionOpt :: Bool        -- -omz: map*zip* fusion
         , elimCommOpt :: Bool        -- -oec: eliminate communications
         , elimIdOpt :: Bool          -- -oei: elmiminate sending id values
         , useV2HOpt :: Bool          -- -ovh: use voteToHalt
         , useMsgCombOpt :: Bool      -- -omc: use message combiner
         , useSmt :: Bool             -- -smt: use SMT solver
         , smtPath :: String          -- -smtpath path: specify path of z3
         , smtOption :: String        -- -smtoption option: option of z3
         , smtTimeout:: Int           -- -smttimeout time: specify timeout
         , printSmt :: Bool
         , genMode :: TargetSystem
         , outputFile :: Maybe String
         }
-- defaultOpt = Option 100 False False False Giraph Nothing
defaultOpt = Option { normLevel = 100
                    , zipOpt = False
                    , pcFusionOpt = False
                    , mzFusionOpt = False
                    , elimCommOpt = False
                    , elimIdOpt = False
                    , useV2HOpt = False
                    , useMsgCombOpt = False
                    , useSmt = False
                    , smtPath = "/usr/local/bin/z3"
                    , smtOption = "-smt2 -in"
                    , smtTimeout = 5 * 10 ^ 6
                    , printSmt = False
                    , genMode = Giraph
                    , outputFile = Nothing
                    }

-- optimization information
type CanElimComm = Bool
type CanVoteToHalt = Bool
type CombineMessages = Bool

type OptimizeInfo = (CanElimComm, CanVoteToHalt, CombineMessages)

-- dependency info.
type DVarName = String

-- type info.
type Id = String
data DTypeTerm = DTypeVar Id
               | DTypeTerm Id [DTypeTerm]
               deriving (Eq, Show)

type DTypeInfo = DTypeTerm
type VarTypeBind = (DVarName, DTypeInfo)

type DUnique = Int

-- the AST data (type info. and dependency info.)
data DASTData = DASTData { typeOf :: DTypeTerm, depOf :: [DVarName] }
              deriving (Eq, Show)

-- type builders
typeVar a = DTypeVar a
typeDTInt = DTypeTerm "Int" []
typeDTBool = DTypeTerm "Bool" []
typeDTString = DTypeTerm "String" []
typeDTDouble = DTypeTerm "Double" []
typeTuple ts = DTypeTerm "(,)" ts
typeRecord c ts = DTypeTerm c ts
getTupleTypes (DTypeTerm "(,)" ts) = ts
typeSolid name = DTypeTerm name []
typeVertex (ts@[tv, te]) = DTypeTerm "Vertex" ts
typeGraph (ts@[tv, te]) = DTypeTerm "Graph" ts
typePair (ts@[tv, te]) = DTypeTerm "Pair" ts
resultTypeVarName = "@@ResultingType@@"
typeNull = DTypeTerm "Null" []
getTypeName (DTypeTerm n _) = n
typeParams (DTypeTerm _ ps) = ps

nullRecordSpec = DRecordSpec (DConstructor "Null" (DASTData typeNull [])) [] (DASTData typeNull [])

getType :: forall (t :: * -> *). 
            (DAdditionalData (t DASTData) DASTData) 
            => t DASTData -> DTypeInfo
getType = typeOf . getData

setType :: forall (t :: * -> *). 
            (DAdditionalData (t DASTData) DASTData) 
            => DTypeInfo -> t DASTData -> t DASTData
setType t x = setData ((getData x) { typeOf = t }) x


isTupleType "(,)" = True
isPrimitive t = t == "Int" || t == "Bool" || t == "String"  || t == "Double" 

typeFunction ts =  foldr1 (\t ft -> DTypeTerm "->" [t, ft]) ts
getInputType (DTypeTerm "->" (x:_)) = x
getVertexType (DTypeTerm "Graph" [tv, te]) = tv
getEdgeType (DTypeTerm "Graph" [tv, te]) = te

-- initial environment: 
initEnv :: [VarTypeBind]
initEnv =
   [("fst", typeFunction [typeTuple [typeVar "a", typeVar "b"], typeVar "a"]),
    ("snd", typeFunction [typeTuple [typeVar "a", typeVar "b"], typeVar "b"]),
    ("Pair", typeFunction [typeVar "a", typeVar "b", typePair [typeVar "a", typeVar "b"]]),
    ("_fst", typeFunction [typePair [typeVar "a", typeVar "b"], typeVar "a"]),
    ("_snd", typeFunction [typePair [typeVar "a", typeVar "b"], typeVar "b"]),
    ("+", typeFunction [typeVar "a", typeVar "a", typeVar "a"]),
    ("/", typeFunction [typeVar "a", typeVar "a", typeVar "a"]),
    ("*", typeFunction [typeVar "a", typeVar "a", typeVar "a"]),
    ("-", typeFunction [typeVar "a", typeVar "a", typeVar "a"]),
    ("neg", typeFunction [typeVar "a", typeVar "a"]),
    ("!=", typeFunction [typeVar "a", typeVar "a", typeDTBool]),
    ("==", typeFunction [typeVar "a", typeVar "a", typeDTBool]),
    (">=", typeFunction [typeVar "a", typeVar "a", typeDTBool]),
    ("<=", typeFunction [typeVar "a", typeVar "a", typeDTBool]),
    ("<", typeFunction [typeVar "a", typeVar "a", typeDTBool]),
    (">", typeFunction [typeVar "a", typeVar "a", typeDTBool]),
    ("||", typeFunction [typeDTBool, typeDTBool, typeDTBool]),
    ("&&", typeFunction [typeDTBool, typeDTBool, typeDTBool]),
    ("not", typeFunction [typeDTBool, typeDTBool]),
    ("min", typeFunction [typeVar "a", typeVar "a", typeVar "a"]),
    ("max", typeFunction [typeVar "a", typeVar "a", typeVar "a"]),
    ("mod", typeFunction [typeVar "a", typeVar "a", typeVar "a"]),
    ("val", typeFunction [typeVertex [typeVar "a", typeVar "b"], typeVar "a"]),
    ("vid", typeFunction [typeVertex [typeVar "a", typeVar "b"], typeDTInt]),
    -- dummy
    ("bot", typeVar "a")]


genNewName i s = (s ++ "_X"++((showHex i "")), i+1) 
getBaseName s = s --if isPrefixOf "_X" s then else s

-- util
lookupBy :: Eq b => (a -> b) -> b -> [a] -> Maybe a
lookupBy _ _ [] = Nothing
lookupBy f key (x:xs) = if f x == key then Just x else lookupBy f key xs

instance PrettyShow [(String, DTypeInfo)] where
  prettyShow env = unlines $ map (\(v, t) -> v ++ "::" ++ prettyShow t) env
                   
instance PrettyShow DTypeInfo where
  prettyShow (DTypeVar a) = a
  prettyShow (DTypeTerm "(,)" ts) = "(" ++ ppList ", " (map prettyShow ts) ++ ")"
  prettyShow (DTypeTerm "->" [h,t]) = "(" ++ prettyShow h ++ " -> " ++ prettyShow t ++ ")"
  prettyShow (DTypeTerm s []) = s
  prettyShow (DTypeTerm s ts) = "(" ++ s ++ " " ++ ppList " " (map prettyShow ts) ++ ")"