├── .gitignore ├── .travis.yml ├── Dockerfile ├── GoParser.hs ├── GoTypes.hs ├── Gong.hs ├── LICENSE ├── Liveness.hs ├── PrettyGoTypes.hs ├── README.md ├── Safety.hs ├── Setup.hs ├── StuffParams.hs ├── SymbolicSem.hs ├── TypeSize.hs ├── Utils.hs ├── examples ├── async-chans.cgo ├── closing-chan.cgo ├── dining-philo.cgo ├── fibonacci-async.cfgo ├── fibonacci.cfgo ├── nofence.cgo ├── not-safe.cgo └── primesieve.cgo ├── gong.cabal └── tests ├── abc.cgo ├── async-basic.cgo ├── async-dual.cgo ├── async-fib-1chan.cgo ├── async-fib.cgo ├── async-finitestate-close.cgo ├── async-finitestate-send.cgo ├── async-finitestate.cgo ├── async-notlive.cgo ├── async-primesieve.cgo ├── badphilo.cgo ├── badprime.cgo ├── basic.cgo ├── blockingasync.cgo ├── closing.cgo ├── fibonacci-1chan.cgo ├── fibonacci.cgo ├── finitestate.cgo ├── freenames.cgo ├── goodphilo.cgo ├── hernan-test1.cgo ├── hernan-test2.cgo ├── home.cgo ├── init.cgo ├── mini.cgo ├── nickseq.cgo ├── norec.cgo ├── notfenced.cgo ├── notlive.cgo ├── primesieve-double.cgo ├── primesieve-nochoice.cgo ├── primesieve.cgo ├── recvclosed.cgo ├── safety.cgo ├── sameparam.cgo ├── select1.cgo ├── synasync.cgo ├── tau.cgo ├── twophilo.cgo └── vbasic.cgo /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: c 3 | 4 | before_install: 5 | - export PATH=/opt/ghc/7.10.3/bin:/opt/cabal/1.24/bin:$PATH 6 | 7 | addons: 8 | apt: 9 | sources: 10 | - hvr-ghc 11 | packages: 12 | - ghc-7.10.3 13 | - cabal-install-1.24 14 | 15 | install: 16 | - travis_retry cabal update 17 | - cabal install --only-dependencies 18 | 19 | script: 20 | - cabal build 21 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ubuntu:16.04 2 | MAINTAINER Nicholas Ng 3 | RUN apt-get -y --no-install-recommends update && \ 4 | apt-get install -y --no-install-recommends haskell-platform git && \ 5 | apt-get clean 6 | RUN cabal update 7 | RUN cd /usr/local/src; git clone git://github.com/nickng/gong.git 8 | RUN cd /usr/local/src/gong; cabal install 9 | RUN cp -v /usr/local/src/gong/dist/build/Gong/Gong /usr/local/bin 10 | CMD /usr/local/bin/Gong 11 | -------------------------------------------------------------------------------- /GoParser.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | module GoParser where 4 | 5 | import Control.Arrow ((+++)) 6 | import Control.Monad 7 | import Control.Monad.Trans.Maybe 8 | import Data.Functor 9 | import Data.List as L 10 | import Data.Set as S 11 | import Data.Maybe 12 | import Control.Applicative ((<*),(*>)) 13 | import Unbound.LocallyNameless 14 | 15 | import qualified Text.ParserCombinators.Parsec as P 16 | import Text.ParserCombinators.Parsec ((<|>),many) 17 | import qualified Text.ParserCombinators.Parsec.Token as T 18 | import Text.ParserCombinators.Parsec.Language 19 | 20 | import qualified GoTypes as GT 21 | import qualified PrettyGoTypes as PP 22 | -- Types -- 23 | 24 | data Prog a = P [Def a] 25 | deriving (Eq, Show) 26 | 27 | data Def a = D String [String] a 28 | deriving (Eq, Show) 29 | 30 | instance Functor Def where 31 | fmap f (D s l p) = D s l (f p) 32 | 33 | instance Functor Prog where 34 | fmap f (P l) = P (fmap (fmap f) l) 35 | 36 | data Interm = Seq [Interm] 37 | | Call String [String] 38 | | Cl String 39 | | Spawn String [String] 40 | | NewChan String String Integer 41 | | If Interm Interm 42 | | Select [Interm] 43 | | T 44 | | S String 45 | | R String 46 | | Zero 47 | deriving (Eq, Show) 48 | 49 | -- Assumptions currently being exploited by Translation to GoTypes: 50 | -- (1) If and Select have no real continuation 51 | -- (2) Parser always terminates every control flow branch with 52 | -- a Zero 53 | 54 | 55 | -- The flow from text to GoTypes/Eqn is: 56 | -- (1) Parse via pparser 57 | -- (2) Eliminate trailing zeros in If/Select/Call 58 | -- (3) Transform into GoTypes/Eqn (with Seq only for non-prefix) 59 | 60 | 61 | type ProgGo = Prog Interm 62 | type DefGo = Def Interm 63 | 64 | 65 | 66 | -- Lexer -- 67 | lexer :: T.TokenParser () 68 | 69 | ldef = emptyDef { T.identStart = P.letter 70 | , T.identLetter = (P.alphaNum <|> P.char '_' <|> P.char '.' 71 | <|> P.char '$'<|> P.char '#') 72 | , T.reservedNames = [ "def" 73 | , "call" 74 | , "close" 75 | , "spawn" 76 | , "let" 77 | , "newchan" 78 | , "select" 79 | , "case" 80 | , "endselect" 81 | , "if" 82 | , "else" 83 | , "endif" 84 | , "tau" 85 | , "send" 86 | , "recv" ] 87 | , T.commentLine = "--" 88 | } 89 | 90 | lexer = T.makeTokenParser ldef 91 | 92 | whiteSpace = T.whiteSpace lexer 93 | reserved = T.reserved lexer 94 | parens = T.parens lexer 95 | identifier = T.identifier lexer 96 | natural = T.natural lexer 97 | integer = T.integer lexer 98 | semi = T.semi lexer 99 | symbol = T.symbol lexer 100 | 101 | -- Parser -- 102 | 103 | seqInterm :: P.Parser Interm 104 | seqInterm = do 105 | list <- P.sepBy1 itparser semi 106 | return $ if L.length list == 1 then head list else Seq list 107 | 108 | pparser :: P.Parser (ProgGo) 109 | pparser = do 110 | l <- many dparser 111 | return $ P l 112 | 113 | 114 | dparser :: P.Parser (DefGo) 115 | dparser = do 116 | { reserved "def" 117 | ; x <- identifier 118 | ; list <- parens (P.sepBy identifier (P.char ',' <* P.spaces)) 119 | ; symbol ":" 120 | ; d <- seqInterm 121 | ; return $ D x list d 122 | } 123 | 124 | 125 | itparser :: P.Parser Interm 126 | itparser = 127 | do { reserved "close" 128 | ; c <- identifier 129 | ; return $ (Cl c) } 130 | <|> 131 | do { reserved "spawn" 132 | ; x <- identifier 133 | ; list <- parens (P.sepBy identifier (P.char ',' <* P.spaces)) 134 | ; return $ Spawn x list } 135 | <|> 136 | do { reserved "select" 137 | ; l <- many (reserved "case" *> seqInterm) 138 | ; reserved "endselect" 139 | ; return $ Select l } 140 | <|> 141 | do { reserved "let" 142 | ; x <- identifier 143 | ; symbol "=" 144 | ; reserved "newchan" 145 | ; t <- identifier 146 | ; symbol "," 147 | ; n <- natural 148 | ; return $ NewChan x t n } 149 | <|> 150 | do { reserved "if" 151 | ; t <- seqInterm 152 | ; reserved "else" 153 | ; e <- seqInterm 154 | ; reserved "endif" 155 | ; return $ If t e } 156 | <|> 157 | do { reserved "tau" 158 | ; return $ T } 159 | <|> 160 | do { reserved "send" 161 | ; c <- identifier 162 | ; return $ S c } 163 | <|> 164 | do { reserved "recv" 165 | ; c <- identifier 166 | ; return $ R c } 167 | <|> 168 | do { reserved "call" 169 | ; c <- identifier 170 | ; list <- parens (P.sepBy identifier (P.char ',' <* P.spaces)) 171 | ; return $ Call c list } 172 | <|> 173 | do { return $ Zero } 174 | 175 | mainparser :: P.Parser (ProgGo) 176 | mainparser = whiteSpace >> pparser <* P.eof 177 | 178 | 179 | parseprog :: String -> Either P.ParseError (ProgGo) 180 | parseprog inp = P.parse mainparser "" inp 181 | 182 | parseTest s = 183 | case parseprog s of 184 | Left err -> print err 185 | Right s -> print s 186 | 187 | 188 | -------- Intermediate representation to GoTypes ------- 189 | 190 | 191 | -- Getting rid of Call;0, Select;0 and If;0 -- 192 | 193 | contzElim :: Interm -> Interm 194 | contzElim (Seq l) = Seq (contzElim' l) 195 | contzElim (If p1 p2) = If (contzElim p1) (contzElim p2) 196 | contzElim (Select l) = Select (L.map contzElim l) 197 | contzElim p = p 198 | 199 | contzElim' (x:y:xs) = case (x,y) of 200 | (Call _ _ , Zero) -> [x] -- No need to keep going 201 | (If p1 p2, Zero) -> [If (contzElim p1) (contzElim p2)] 202 | (Select l , Zero) -> [Select (L.map contzElim l)] 203 | (_,_) -> (contzElim x):(contzElim' (y:xs)) 204 | contzElim' ([x]) = [contzElim x] 205 | contzElim' [] = [] 206 | 207 | 208 | contzElimProg :: ProgGo -> ProgGo 209 | contzElimProg = fmap contzElim 210 | 211 | 212 | 213 | --- Transforming processed Prog into Eqn/GoTypes --- 214 | 215 | 216 | transform :: [String] -> Interm -> GT.GoType 217 | transform vars (Seq l) = transformSeq vars l 218 | transform vars t = transform vars (Seq [t]) 219 | 220 | 221 | 222 | throwError :: [String] -> [String] -> GT.GoType -> GT.GoType 223 | throwError current known ty = 224 | if and $ L.map (\x -> x `elem` known) current 225 | then ty 226 | else error $ "Some of "++(show current)++" are not declared." 227 | 228 | transformSeq :: [String] -> [Interm] -> GT.GoType 229 | transformSeq vars (x:xs) = 230 | case x of 231 | (Call s l) -> throwError l vars $ 232 | GT.Seq [(GT.ChanInst (GT.TVar (s2n s)) (L.map s2n l)), (transformSeq vars xs) ] 233 | 234 | (Cl s) -> throwError [s] vars $ 235 | GT.Close (s2n s) (transformSeq vars xs) 236 | 237 | (Spawn s l) -> throwError l vars $ 238 | GT.Par [(GT.ChanInst (GT.TVar (s2n s)) (L.map s2n l)) , (transformSeq vars xs)] 239 | 240 | (NewChan s1 s2 n) -> GT.New (fromIntegral n) (bind (s2n s1) (transformSeq (s1:vars) xs)) 241 | 242 | (If p1 p2) -> GT.IChoice (transform vars p1) (transform vars p2) 243 | 244 | (Select l) -> GT.OChoice (L.map (transform vars) l) 245 | 246 | (T) -> GT.Tau (transformSeq vars xs) 247 | 248 | (S s) -> throwError [s] vars $ 249 | GT.Send (s2n s) (transformSeq vars xs) 250 | 251 | (R s) -> throwError [s] vars $ 252 | GT.Recv (s2n s) (transformSeq vars xs) 253 | (Zero) -> GT.Null 254 | transformSeq vars [] = GT.Null 255 | 256 | transformDef (D s l p) = (s2n s , Embed(GT.ChanAbst (bind (L.map s2n l) (transform l p)))) 257 | transformMain (D _ vars p) = transform vars p 258 | 259 | transformProg :: ProgGo -> GT.Eqn 260 | transformProg (P l) = let main = head l 261 | defs = tail l 262 | in GT.EqnSys (bind (rec (L.map transformDef defs)) (transformMain main)) 263 | 264 | 265 | fullPass :: String -> Either P.ParseError (GT.Eqn) 266 | fullPass s = case (parseprog s) of 267 | Left err -> Left err 268 | Right p -> Right (transformProg . contzElimProg $ p) 269 | 270 | passTest :: String -> GT.Eqn 271 | passTest s = case (fullPass s) of 272 | Right e -> e 273 | Left err -> error "Failed to parse" 274 | 275 | ---- Testing Area ---- 276 | 277 | assert :: String -> Bool -> IO () 278 | assert s True = return () 279 | assert s False = print ("Assertion " ++ s ++ " failed") 280 | 281 | testerFile :: String -> IO () 282 | testerFile s = do 283 | f <- readFile s 284 | print ("Attempting to Parse: " ++ f) 285 | let e = passTest f 286 | putStr "Succeeded: " 287 | print . PP.pprintEqn $ e 288 | 289 | testerStr :: String -> IO () 290 | testerStr s = do 291 | print ("Attempting to Parse: " ++ s) 292 | let e = passTest s 293 | putStr "Succeeded: " 294 | print . PP.pprintEqn $ e 295 | 296 | p1 = "def t0() : tau ; call t0 () ; def t1(a) : send a ; call t1(a) ; def t2(b) : recv a ; call t2 (b) ;" 297 | p2 = "def t0() : spawn t1(a) ; spawn t2(a) ; def t1(a) : send a ; call t1(a) ; def t2(b) : recv b ; call t2 (b) ;" 298 | p3 = "def t0() : let a = newchan xpto , 0 ; spawn t1(a) ; spawn t2(a) ; def t1(a) : send a ; call t1(a) ; def t2(b) : recv a ; call t2 (b);" 299 | p4 = "def main() : let a = newchan xpto, 0 ; spawn r(a) ; call t(a) ; def t(b) : recv b ;" 300 | 301 | test :: IO () 302 | test = 303 | mapM_ testerStr [p1,p2,p3,p4] 304 | 305 | 306 | -------------------------------------------------------------------------------- /GoTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses 2 | , TemplateHaskell 3 | , ScopedTypeVariables 4 | , FlexibleInstances 5 | , FlexibleContexts 6 | , UndecidableInstances 7 | , DeriveGeneric, DeriveAnyClass 8 | #-} 9 | 10 | module GoTypes where 11 | 12 | import Unbound.LocallyNameless hiding (Generic) 13 | 14 | import Control.Applicative 15 | import Control.Arrow ((+++)) 16 | import Control.Monad 17 | import Control.Monad.Trans.Maybe 18 | import Data.List as L 19 | import Data.Set (Set) 20 | import qualified Data.Set as S 21 | import Data.Maybe 22 | 23 | import GHC.Generics (Generic) 24 | import Control.DeepSeq 25 | 26 | 27 | -- DEBUG 28 | import System.IO.Unsafe 29 | import Debug.Trace 30 | 31 | data Channel 32 | 33 | type ChName = Name Channel 34 | 35 | 36 | type EqnName = Name GoType 37 | 38 | 39 | data GoType = Send ChName GoType 40 | | Recv ChName GoType 41 | | Tau GoType 42 | | IChoice GoType GoType -- Just two things? 43 | | OChoice [GoType] 44 | | Par [GoType] 45 | | New Int (Bind ChName GoType) 46 | | Null 47 | | Close ChName GoType 48 | | TVar EqnName 49 | | ChanInst GoType [ChName] -- P(c) 50 | | ChanAbst (Bind [ChName] GoType) -- \c.P 51 | | Seq [GoType] 52 | | Buffer ChName (Bool, Int, Int) -- True when Open, Bound, Current 53 | | ClosedBuffer ChName -- Only used for guard/label 54 | deriving (Show) 55 | 56 | 57 | isBuffer :: GoType -> Bool 58 | isBuffer (Buffer _ _) = True 59 | isBuffer _ = False 60 | 61 | data Eqn = EqnSys (Bind (Rec [(EqnName , Embed GoType)]) GoType) 62 | deriving (Show) 63 | -- inner Proc will always be ChanAbst 64 | 65 | $(derive [''Channel,''GoType,''Eqn]) 66 | 67 | --instance Alpha Channel 68 | instance Alpha GoType 69 | instance Alpha Eqn 70 | 71 | 72 | -- -- PARALLEL STUFF 73 | -- instance NFData GoType where rnf x = seq x () 74 | -- instance NFData Eqn where rnf x = seq x () 75 | -- instance NFData (Name a) where rnf x = seq x () 76 | 77 | instance Subst GoType Eqn 78 | --instance Subst String GoType 79 | --instance Subst String Eqn 80 | 81 | instance Subst GoType GoType where 82 | isvar (TVar x) = Just (SubstName x) 83 | isvar _ = Nothing 84 | 85 | type M a = FreshM a 86 | 87 | 88 | -- Free name/var wrappers -- 89 | fnTyp :: GoType -> [ChName] 90 | fnTyp t = fv t 91 | 92 | fvTyp :: GoType -> [EqnName] 93 | fvTyp t = fv t 94 | 95 | fnEqn :: Eqn -> [ChName] 96 | fnEqn e = fv e 97 | 98 | fvEqn :: Eqn -> [EqnName] 99 | fvEqn e = fv e 100 | 101 | 102 | -- GoType Combinators (TVars, New, Chan Abs and Inst) -- 103 | tvar :: String -> GoType 104 | tvar = TVar . s2n 105 | 106 | new :: Int -> String -> GoType -> GoType 107 | new i s t = New i $ bind (s2n s) t 108 | 109 | chanAbst :: String -> GoType -> GoType 110 | chanAbst s t = ChanAbst $ bind ([s2n s]) t 111 | 112 | chanAbstL :: [String] -> GoType -> GoType 113 | chanAbstL l t = ChanAbst $ bind (L.map s2n l) t 114 | 115 | chanInst :: String -> String -> GoType 116 | chanInst s c = ChanInst (tvar s) ([s2n c]) 117 | 118 | chanInstL :: String -> [String] -> GoType 119 | chanInstL s l = ChanInst (tvar s) (L.map s2n l) 120 | 121 | ------------------------------ 122 | 123 | -- Equation System Combinators -- 124 | 125 | eqn' :: String -> GoType -> GoType -> Eqn 126 | eqn' s t1 t2 = EqnSys (bind (rec [(s2n s , Embed(t1) )]) t2) 127 | 128 | eqn :: String -> String -> GoType -> GoType -> Eqn 129 | eqn s c t1 t2 = eqn' s (chanAbst c t1) t2 130 | 131 | 132 | 133 | eqnl :: [(String,[String],GoType)] -> GoType -> Eqn 134 | eqnl l t = EqnSys (bind (rec (L.map (\(var,plist,def) -> 135 | (s2n var , Embed(chanAbstL plist def)) 136 | ) l)) t) 137 | 138 | ---------------------------------------- 139 | 140 | -- Structural Congruence -- 141 | 142 | -- Flatten out Pars in Par (i.e. T | (S | R) == (T | S) | R)-- 143 | flattenPar :: GoType -> GoType 144 | flattenPar (Par l) = Par (flattenPar' l) 145 | where flattenPar' (x:xs) = 146 | case x of 147 | Par l -> case (flattenPar x) of 148 | Par l' -> l'++(flattenPar' xs) 149 | t -> t:(flattenPar' xs) 150 | _ -> x:(flattenPar' xs) 151 | flattenPar' [] = [] 152 | flattenPar t = t 153 | 154 | -- Remove Nulls from Par (i.e. T | 0 == T)-- 155 | gcNull :: GoType -> GoType 156 | gcNull (Par l) = let res = gcNull' l in 157 | if (L.null res) then Null else Par res 158 | where gcNull' (x:xs) = 159 | case x of 160 | Null -> gcNull' xs 161 | _ -> x:(gcNull' xs) 162 | gcNull' [] = [] 163 | gcNull t = t 164 | 165 | -- GC unused bound names -- 166 | gcBNames' :: GoType -> M GoType 167 | gcBNames' (Send c t) = do 168 | t' <- gcBNames' t 169 | return $ Send c t' 170 | gcBNames' (Recv c t) = do 171 | t' <- gcBNames' t 172 | return $ Recv c t' 173 | gcBNames' (Tau t) = do 174 | t' <- gcBNames' t 175 | return $ Tau t' 176 | gcBNames' (IChoice t1 t2) = do 177 | t1' <- gcBNames' t1 178 | t2' <- gcBNames' t2 179 | return $ IChoice t1' t2' 180 | gcBNames' (OChoice l) = do 181 | lm' <- mapM gcBNames' l 182 | return $ OChoice lm' 183 | gcBNames' (Par l) = do 184 | lm' <- mapM gcBNames' l 185 | return $ Par lm' 186 | gcBNames' (New i bnd) = do 187 | (c,t) <- unbind bnd 188 | t' <- gcBNames' t 189 | -- GC if c not used 190 | if c `S.notMember` fv t' 191 | then return t' 192 | else return (New i (bind c t')) 193 | gcBNames' (Null) = return Null 194 | gcBNames' buf@(Buffer c _) = return buf 195 | gcBNames' (Close c t) = do 196 | t' <- gcBNames' t 197 | return $ Close c t' 198 | gcBNames' (TVar x) = return $ TVar x 199 | gcBNames' (ChanInst t lc) = do -- P(~c) 200 | t' <- gcBNames' t 201 | return $ ChanInst t' lc 202 | gcBNames' (ChanAbst bnd) = do 203 | (c,t) <- unbind bnd 204 | t' <- gcBNames' t 205 | return $ ChanAbst (bind c t') 206 | gcBNames' (Seq l) = do 207 | l' <- mapM gcBNames' l 208 | return $ Seq l' 209 | 210 | 211 | gcBNames :: GoType -> GoType 212 | gcBNames = runFreshM . gcBNames' 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | -- Open top-level bound names in a list of parallel types -- 221 | -- return is a list of (mc,t) where mc is Nothing if t is 222 | -- closed and Just(c) otherwise. 223 | openBNames :: [GoType] -> M [([Maybe (Int, ChName)],GoType)] 224 | openBNames (x:xs) = do 225 | (l,t) <- openBNamesT x 226 | rest <- openBNames xs 227 | return $ (l,t):rest 228 | openBNames [] = return $ [([Nothing],Null)] 229 | 230 | openBNamesT :: GoType -> M ([Maybe (Int, ChName)], GoType) 231 | openBNamesT (New i bnd) = do 232 | (c,t) <- unbind bnd 233 | (l,t') <- openBNamesT t 234 | return $ ( Just(i,c):l , t') 235 | openBNamesT t = return $ ([Nothing],t) 236 | 237 | 238 | -- Reconstructs the appropriate GoType from calls 239 | -- to openBNames 240 | closeBNames :: M [([Maybe (Int, ChName)],GoType)] -> M GoType 241 | closeBNames m = do 242 | l <- m 243 | let (names,ts) = unzip l 244 | let names' = concat names 245 | return $ L.foldr (\mc end -> 246 | case mc of 247 | Just(i,c) -> New i (bind c end) 248 | Nothing -> end) (Par ts) names' 249 | 250 | -- Composes open/close and escapes the freshness monad -- 251 | pullBNamesPar :: GoType -> GoType 252 | pullBNamesPar (Par l) = 253 | runFreshM (closeBNames . openBNames $ l) 254 | pullBNamesPar t = t 255 | 256 | 257 | nf :: M GoType -> M GoType 258 | nf t = do t1 <- t 259 | (nf' (gcBNames t1)) 260 | where nf' Null = return Null 261 | nf' (Send c t) = do 262 | t' <- nf' t 263 | return $ (Send c t') 264 | nf' (Recv c t) = do 265 | t' <- nf' t 266 | return $ (Recv c t') 267 | nf' (Tau t) = do 268 | t' <- nf' t 269 | return $ (Tau t') 270 | nf' (IChoice t1 t2) = do 271 | t1' <- nf' t1 272 | t2' <- nf' t2 273 | return $ IChoice t1' t2' 274 | nf' (OChoice l) = do 275 | l' <- mapM nf' l 276 | return $ OChoice l' 277 | nf' t@(Par l) = do 278 | let t' = (gcNull . pullBNamesPar . flattenPar $ t) 279 | case t' of 280 | Par l' -> do 281 | l'' <- mapM nf' l' 282 | return $ Par l'' 283 | _ -> nf' t' 284 | nf' (New i bnd) = do 285 | (c,t) <- unbind bnd 286 | t' <- nf' t 287 | return $ (New i (bind c t')) 288 | nf' (Close c t) = do 289 | t' <- nf' t 290 | return $ (Close c t') 291 | nf' (TVar x) = return $ TVar x 292 | nf' t@(ChanInst t0 l) = return $ t 293 | nf' (ChanAbst bnd) = do 294 | (l,t) <- unbind bnd 295 | t' <- nf' t 296 | return $ (ChanAbst (bind l t')) 297 | nf' (Seq l) = do 298 | l' <- mapM nf' l 299 | return $ Seq l' 300 | nf' buf@(Buffer c _) = return buf 301 | 302 | 303 | -- structCong :: GoType -> GoType -> Bool 304 | -- structCong t1 t2 = (nf t1) `aeq` (nf t2) 305 | 306 | 307 | ----------- 308 | 309 | 310 | gcBufferList :: [ChName] -> [GoType] -> [GoType] -> [GoType] 311 | gcBufferList names prev [] = prev 312 | gcBufferList names prev (x:xs) = case x of 313 | Null -> gcBufferList names prev xs 314 | Buffer c (o,i,j) -> 315 | if (j == 0) || (c `L.elem` names) || (not o) 316 | then let fna ys = L.foldr (++) [] $ L.map fv ys 317 | left = fna prev 318 | right = fna xs 319 | in if (c `L.elem` (right++left)) || ((L.null prev) && (L.null xs)) 320 | then gcBufferList names (prev++[x]) xs 321 | else gcBufferList names prev xs 322 | else gcBufferList names (prev++[x]) xs 323 | otherwise -> gcBufferList names (prev++[x]) xs 324 | 325 | gcBuffer :: M GoType -> M GoType 326 | gcBuffer t = do t' <- t 327 | gcBuffer' [] t' 328 | 329 | gcBuffer' :: [ChName] -> GoType -> M GoType 330 | gcBuffer' names (Par list) = return $ Par $ gcBufferList names [] list 331 | gcBuffer' names (New i bnd) = do 332 | (c,t) <- unbind bnd 333 | t' <- gcBuffer' (c:names) t 334 | return $ New i (bind c t') 335 | gcBuffer' names t = return t 336 | 337 | -- Once unfoldings of GoTypes and EquationSys -- 338 | 339 | unfoldType :: GoType -> M GoType 340 | unfoldType (Send c t) = do 341 | t' <- unfoldType t 342 | return $ Send c t' 343 | unfoldType (Recv c t) = do 344 | t' <- unfoldType t 345 | return $ Recv c t' 346 | 347 | unfoldType (Tau t) = do 348 | t' <- unfoldType t 349 | return $ Tau t' 350 | unfoldType (IChoice t1 t2) = do 351 | t1' <- unfoldType t1 352 | t2' <- unfoldType t2 353 | return $ IChoice t1' t2' 354 | unfoldType (OChoice l) = do 355 | lm' <- mapM unfoldType l 356 | return $ OChoice lm' 357 | unfoldType (Par l) = do 358 | lm' <- mapM unfoldType l 359 | return $ Par lm' 360 | unfoldType (New i bnd) = do 361 | (c,t) <- unbind bnd 362 | t' <- unfoldType t 363 | -- GC if c not used 364 | if c `S.notMember` fv t' 365 | then return t' 366 | else return (New i (bind c t')) 367 | unfoldType (Null) = return Null 368 | unfoldType (Close c t) = do 369 | t' <- unfoldType t 370 | return $ Close c t' 371 | unfoldType (TVar x) = return $ TVar x 372 | unfoldType (ChanInst t lc) = do -- P(~c) 373 | t' <- unfoldType t 374 | case t' of 375 | ChanAbst bnd -> do -- P == (\~d.P)(~c) 376 | (ld,t0) <- unbind bnd 377 | let perm = L.foldr (\(d,c) acc -> compose acc (single (AnyName d) (AnyName c)) ) 378 | (Unbound.LocallyNameless.empty) (zip ld lc) 379 | return $ swaps perm t0 380 | otherwise -> return $ ChanInst t' lc 381 | unfoldType (ChanAbst bnd) = do 382 | (c,t) <- unbind bnd 383 | t' <- unfoldType t 384 | return $ ChanAbst (bind c t') 385 | unfoldType (Seq l) = do 386 | l' <- mapM unfoldType l 387 | return $ Seq l' 388 | 389 | 390 | unfoldEqn :: Eqn -> M Eqn 391 | unfoldEqn (EqnSys bnd) = do 392 | (r,body) <- unbind bnd 393 | let vars = unrec r 394 | let newbody = L.foldr (\(x,Embed rhs) body -> subst x rhs body) body vars 395 | return $ EqnSys (bind (rec vars) newbody) 396 | 397 | unfoldTop :: Eqn -> M Eqn 398 | unfoldTop (EqnSys bnd) = do 399 | (r,body) <- unbind bnd 400 | let vars = unrec r 401 | let newbody = L.foldr (\(x,Embed rhs) body -> subst x rhs body) body vars 402 | bla <- unfoldType newbody 403 | return $ EqnSys (bind (rec vars) bla) 404 | 405 | 406 | ---- Fencing predicate for types ---- 407 | 408 | -- G ; ~y ; ~z |-t T 409 | -- G records previously encountered recursive calls 410 | -- ~y represents names that t can use if T is single-threaded 411 | -- ~z represents names that a sub-process of T can use if T is multi-threaded 412 | 413 | 414 | -- EqnSys (Bind (Rec [(EqnName , Embed GoType)]) GoType) 415 | 416 | finMem :: (Eq a) => [a] -> [a] -> Bool 417 | finMem l1 l2 = not (null l1 || null l2 || (length l1 /= length l2)) && 418 | let sl1 = tail (inits l1) in 419 | aux sl1 l2 l1 420 | where aux (x:y:xs) l l1 = if (L.isSuffixOf x l) then 421 | null ((drop (length x) l1) `intersect` l) 422 | else 423 | aux (y:xs) l l1 424 | aux [x] l l1 = null (x `intersect` l) 425 | aux [] l l1 = False 426 | 427 | -- abd `finMem` abc = True 428 | -- abc `finMem` abc = False 429 | -- bcda `finMem` abcd = False 430 | -- cdab `finMem` abcd = False 431 | -- cdaa `finMem` abcd = False 432 | 433 | checkFinite :: Bool -> [(EqnName , Embed GoType)] -> (Set EqnName) -> 434 | [ChName] -> [ChName] -> EqnName -> GoType -> M Bool 435 | checkFinite debug defEnv pRecs ys zs cDef (Send c t) = checkFinite debug defEnv pRecs ys zs cDef t 436 | checkFinite debug defEnv pRecs ys zs cDef (Recv c t) = checkFinite debug defEnv pRecs ys zs cDef t 437 | checkFinite debug defEnv pRecs ys zs cDef (Tau t) = checkFinite debug defEnv pRecs ys zs cDef t 438 | checkFinite debug defEnv pRecs ys zs cDef (IChoice t1 t2) = do 439 | b1 <- checkFinite debug defEnv pRecs ys zs cDef t1 440 | b2 <- checkFinite debug defEnv pRecs ys zs cDef t2 441 | return $ b1 && b2 442 | checkFinite debug defEnv pRecs ys zs cDef (OChoice l) = do 443 | foldM (\acc t -> do 444 | b <- checkFinite debug defEnv pRecs ys zs cDef t 445 | return $ b && acc) True l 446 | checkFinite debug defEnv pRecs ys zs cDef (Par [t]) = checkFinite debug defEnv pRecs ys zs cDef t 447 | checkFinite debug defEnv pRecs ys zs cDef (Par l) = do 448 | foldM (\acc t -> do 449 | b <- checkFinite debug defEnv pRecs [] (zs++ys) cDef t 450 | return $ b && acc) True l 451 | checkFinite debug defEnv pRecs ys zs cDef (New i bnd) = do 452 | (c,t) <- unbind bnd 453 | checkFinite debug defEnv pRecs ys zs cDef t 454 | checkFinite debug defEnv pRecs ys zs cDef (Null) = return $ True 455 | checkFinite debug defEnv pRecs ys zs cDef (Close c t) = checkFinite debug defEnv pRecs ys zs cDef t 456 | checkFinite debug defEnv pRecs ys zs cDef t@(TVar x) = error $ "[checkFinite] Oops: "++(show t) 457 | -- Should be handled in ChanInst 458 | checkFinite debug defEnv pRecs ys zs cDef (ChanInst (TVar x) l) = 459 | if (x == cDef) then 460 | -- return $ ((not . null $ ys) || (l `finMem` zs)) 461 | if ((not . null $ ys) || (l `finMem` zs)) 462 | then return True 463 | else if debug 464 | then error $ "Not fenced: "++(show ((l,zs),ys)) 465 | else return False 466 | else 467 | if (x `S.member` pRecs) then 468 | return $ True 469 | else 470 | do 471 | let tdef = (case (L.lookup x defEnv) of 472 | Just(Embed(t)) -> t 473 | _ -> error $ "Something went wrong, can't find: "++(show x)) 474 | let tabs = (case tdef of 475 | ChanAbst bnd -> bnd 476 | _ -> error "boom! wtf") 477 | (params,abs) <- unbind tabs 478 | let perm = L.foldr (\(d,c) acc -> compose acc (single (AnyName d) (AnyName c)) ) 479 | (Unbound.LocallyNameless.empty) (zip params l) 480 | checkFinite debug defEnv (S.insert x pRecs) ys zs cDef (swaps perm abs) 481 | checkFinite debug defEnv pRecs ys zs cDef (ChanAbst bnd) = return $ True -- this shouldn't come up here I think 482 | checkFinite debug defEnv pRecs ys zs cDef (Seq l) = do 483 | foldM (\acc t -> do 484 | b <- checkFinite debug defEnv pRecs ys zs cDef t 485 | return $ b && acc) True l 486 | 487 | 488 | -- maybe just check main? 489 | checkFiniteP debug (EqnSys bnd) = do 490 | (defs,main) <- unbind bnd 491 | let defEnv = unrec defs 492 | b <- foldM (\acc (x,Embed(ChanAbst bnd)) -> do 493 | (l,t) <- unbind bnd 494 | b <- if null l then return True else checkFinite debug defEnv (S.empty) l [] x t 495 | return $ (acc && b)) True defEnv 496 | b' <- checkFinite debug defEnv (S.empty) [] [] (s2n "main") main 497 | return $ (b && b') 498 | 499 | runCheck :: Bool -> Eqn -> Bool 500 | runCheck debug p = runFreshM $ checkFiniteP debug p 501 | 502 | -------------------------------------------------------------------------------- /Gong.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, BangPatterns #-} 2 | 3 | import GoParser (fullPass) 4 | import GoTypes 5 | import PrettyGoTypes (pprintEqn, pprintType, pprintTypeList) 6 | import SymbolicSem 7 | import Liveness 8 | import Safety 9 | import TypeSize (maxnestednames, sizeOfEqs) 10 | 11 | import Data.List as L 12 | import Unbound.LocallyNameless (runFreshM,unbind) 13 | 14 | import System.Environment 15 | import System.FilePath.Posix 16 | import System.Process 17 | import System.Console.CmdArgs 18 | import Control.Monad 19 | import System.Console.ANSI 20 | 21 | 22 | data CheckMode = Safety 23 | | Liveness 24 | | All 25 | | Debug 26 | | List 27 | | ParLive 28 | deriving (Data,Typeable,Show,Eq) 29 | 30 | data Checker = Checker 31 | { check :: CheckMode 32 | , gofile :: String 33 | , kbound :: Int -- NB: if set to 888, will use EXPERIMENTAL parallelisation of Liveness 34 | } 35 | deriving (Data,Typeable,Show,Eq) 36 | 37 | submodes = enum 38 | [ All &= help "Check liveness and behavioural safety (default) " &= name "A" 39 | , Liveness &= help "Check liveness" &= name "L" 40 | , Safety &= help "Check behavioural safety" &= name "S" 41 | , Debug &= help "Show liveness/safety error terms (debug)" &= name "D" 42 | , List &= help "Show list of k-reachable terms (debug)" &= name "N" 43 | ] 44 | 45 | subargs = Checker { check = submodes 46 | , gofile = def &= argPos 0 &= typ "FILE" 47 | , kbound = def &= opt "-1" &= argPos 1 &= typ "INT (optional bound)" 48 | } 49 | &= help "Go-Types liveness and safety checks" 50 | 51 | 52 | main :: IO () 53 | main = do 54 | pargs <- cmdArgs (modes [subargs]) 55 | tyfile <- (readFile $ gofile pargs) 56 | case fullPass tyfile of 57 | Left err -> print err 58 | Right ty -> do if runCheck ((check pargs) == Debug) ty 59 | then do 60 | let bound = if (kbound pargs) == -1 || (kbound pargs) == 888 61 | then maximum [maxnestednames ty, sizeOfEqs ty] 62 | else kbound pargs 63 | let listsys = succs bound ty 64 | let !tylist = runFreshM listsys 65 | putStrLn $ "Bound (k): "++(show bound) 66 | putStrLn $ "Number of k-states: "++(show $ length tylist) 67 | when ((check pargs) == Debug || (check pargs)==List) $ do 68 | let debugty = runFreshM $ getTypes tylist 69 | putStrLn $ "\n[Debug]k-reachable states:\n"++(pprintTypeList debugty) 70 | when ((check pargs) == Liveness || (proceed pargs)) $ 71 | do let live = runFreshM $ liveness ((check pargs) == Debug) bound listsys 72 | printResult "Liveness" $ if (kbound pargs) == 888 73 | then mapLiveness bound tylist 74 | else live 75 | when ((check pargs) == Safety || (proceed pargs)) $ 76 | do let safe = runFreshM $ safety ((check pargs) == Debug) bound listsys 77 | printResult "Safety" safe 78 | 79 | else do selectColor False 80 | putStrLn $ (gofile pargs)++" is not fenced" 81 | setSGR [Reset] 82 | 83 | 84 | -- separate :: M [Eqn] -> [M Eqn] 85 | -- separate eqs = let fresh = runFreshM eqs 86 | -- in L.map return fresh 87 | 88 | getTypes :: [Eqn] -> M [GoType] 89 | getTypes [] = return [] 90 | getTypes ((EqnSys bnd):xs) = do (defs, main) <- unbind bnd 91 | rest <- getTypes xs 92 | return (main:rest) 93 | 94 | 95 | printResult :: String -> Bool -> IO() 96 | printResult s t = do putStr $ s++": " 97 | selectColor t 98 | putStrLn $ show t 99 | setSGR [Reset] 100 | 101 | selectColor :: Bool -> IO() 102 | selectColor True = setSGR [SetColor Foreground Vivid Green] 103 | selectColor False = setSGR [SetColor Foreground Vivid Red] 104 | 105 | 106 | proceed :: Checker -> Bool 107 | proceed args = (check args == All) || (check args == Debug) 108 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /Liveness.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Liveness where 3 | 4 | import GoTypes 5 | import SymbolicSem 6 | import Utils 7 | import PrettyGoTypes 8 | 9 | 10 | import Unbound.LocallyNameless 11 | import Unbound.LocallyNameless.Ops 12 | 13 | import Control.Parallel.Strategies 14 | import Data.List as L 15 | import Data.Set as S (intersection, null, fromList, toList) 16 | 17 | -- import Control.Monad.Trans.State.Lazy 18 | -- import Control.Monad 19 | -- import Control.Concurrent.Async 20 | 21 | -- DEBUG 22 | import System.IO.Unsafe 23 | import Debug.Trace 24 | 25 | 26 | -- Barbs of a "sequential" type 27 | barbs :: GoType -> [GoType] 28 | barbs (Send n t) = [Send n Null] 29 | barbs (Recv n t) = [Recv n Null] 30 | barbs (OChoice xs) = L.foldr (++) [] $ L.map barbs xs 31 | barbs (New i bnd) = let (c,ty) = unsafeUnbind bnd 32 | in barbs ty 33 | barbs (Par xs) = L.foldr (++) [] $ L.map barbs xs 34 | barbs (Buffer c (open,b,k)) 35 | | (k < b) && (k > 0) = [Send c Null, Recv c Null] 36 | | k > 0 = [Send c Null] 37 | | k < b = [Recv c Null] 38 | | not open = [Send c Null] 39 | | otherwise = [] 40 | barbs t = [] 41 | 42 | 43 | synchronise :: [GoType] -> [GoType] -> Bool 44 | synchronise [] _ = True -- No barbs: always good 45 | synchronise [g] xs = not $ L.null $ L.filter (\x -> match x g) xs 46 | synchronise list@(x:y:xs) ys = 47 | let prod = cartProd list ys 48 | in not $ L.null $ L.filter (\(x,y) -> match x y) prod 49 | 50 | 51 | matchTypes :: GoType -> GoType -> Bool 52 | matchTypes current candidate = 53 | synchronise (barbs current) (barbs candidate) 54 | 55 | findMatch :: GoType -> [GoType] -> Bool 56 | findMatch _ [] = False 57 | findMatch t@(OChoice ys) (x:xs) = if any isTau ys 58 | then True 59 | else (matchTypes t x) 60 | || 61 | (findMatch t xs) 62 | findMatch current (x:xs) = (matchTypes current x) 63 | || 64 | (findMatch current xs) 65 | 66 | 67 | eqnToTypes :: M [Eqn] -> M [GoType] 68 | eqnToTypes mlist = do list <- mlist 69 | helper list 70 | where helper :: [Eqn] -> M [GoType] 71 | helper ((EqnSys x):xs) = do (d,t) <- unbind x 72 | rest <- helper xs 73 | return $ (t:rest) 74 | helper [] = return [] 75 | 76 | -- Given a parallel composition of type, check whether each 77 | -- one can make a move 78 | -- 79 | checkStates :: [ChName] -> Int -> Rec [(EqnName, Embed GoType)] -> [GoType] -> [GoType] -> M Bool 80 | checkStates names k sys prev [] = return True 81 | checkStates names k sys prev (x:next) = 82 | if isBuffer x 83 | then checkStates names k sys (prev++[x]) next 84 | else 85 | do let temp = succsNode k names (EqnSys $ bind sys (Par (prev++next))) :: M [Eqn] 86 | nexts <- temp 87 | gotypes <- eqnToTypes temp 88 | rest <- (checkStates names k sys (prev++[x]) next) 89 | return $ 90 | ( 91 | -- if 92 | (findMatch x gotypes) 93 | -- then True 94 | -- else error $ show (pprintType x ,L.map pprintType gotypes) 95 | ) 96 | && rest 97 | 98 | 99 | liveness :: Bool -> Int -> M [Eqn] -> M Bool 100 | liveness debug k eqs = 101 | do list <- eqs 102 | case list of 103 | (sys@(EqnSys bnd):xs) -> 104 | do (defs, main) <- unbind bnd 105 | ty <- -- trace (show (defs,main)) $ 106 | extractType (return main) 107 | let names = L.nub $ fv ty :: [ChName] 108 | out <- checkStates names k defs [] ty 109 | if out 110 | then liveness debug k $ return xs 111 | else if debug 112 | then error $ "Term not live: " ++(show $ L.map pprintType ty) 113 | else return False 114 | [] -> return True 115 | 116 | 117 | 118 | 119 | -- ATTEMPT AT PARALLELISATION OF LIVENESS 120 | -- 121 | atomLiveness :: Int -> Eqn -> Bool 122 | atomLiveness k eq = runFreshM $ helper k eq 123 | where helper k eq = 124 | case eq of 125 | sys@(EqnSys bnd) -> 126 | do (defs, main) <-unbind bnd 127 | ty <- -- trace (show (defs,main)) $ 128 | extractType (return main) 129 | let names = L.nub $ fv ty 130 | checkStates names k defs [] ty 131 | 132 | 133 | 134 | mapLiveness :: Int -> [Eqn] -> Bool 135 | mapLiveness k eqs = helper 136 | where helper = 137 | let list = map (atomLiveness k) eqs `using` parListChunk ((length eqs) `div` 8) rpar 138 | in L.and list 139 | 140 | -- atomLiveness :: Int -> Eqn -> M Bool 141 | -- atomLiveness k eq = helper k eq 142 | -- where helper k eq = 143 | -- case eq of 144 | -- sys@(EqnSys bnd) -> 145 | -- do (!defs, main) <- unbind bnd 146 | -- ty <- trace (show main) $ extractType (return main) 147 | -- let names = L.nub $ fv ty :: [ChName] 148 | -- checkStates names k defs [] ty 149 | 150 | 151 | 152 | -- -- mkStrat :: Strategy a -> Strategy m [a] 153 | 154 | -- mapLiveness :: Int -> M [Eqn] -> M Bool 155 | -- mapLiveness k eqs' = helper 156 | -- where helper = do eqs <- eqs' 157 | -- let list = (mapM (atomLiveness k) eqs :: M [Bool]) 158 | -- `using` rpar -- (parListChunk ((length eqs) `div` 8) rpar) 159 | -- list' <- list 160 | -- return $ L.and list' 161 | 162 | 163 | -- metaLiveness :: Int -> M [Eqn] -> M Bool 164 | -- metaLiveness k eqs' = helper 165 | -- where helper = do eqs <- eqs' 166 | -- let (left,right) = splitAt ((length eqs) `div` 2) eqs 167 | -- t1 <- async return $ map (atomLiveness k) left 168 | -- t2 <- async return $ map (atomLiveness k) right 169 | -- w1 <- wait t1 170 | -- w2 <- wait t2 171 | -- return $ w1 && w2 172 | -------------------------------------------------------------------------------- /PrettyGoTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses 2 | , TemplateHaskell 3 | , ScopedTypeVariables 4 | , FlexibleInstances 5 | , FlexibleContexts 6 | , UndecidableInstances 7 | #-} 8 | 9 | 10 | module PrettyGoTypes where 11 | 12 | 13 | import Unbound.LocallyNameless 14 | import Control.Applicative 15 | import Control.Arrow ((+++)) 16 | import Control.Monad 17 | import Control.Monad.Trans.Maybe 18 | import Data.List as L 19 | import Data.Set as S 20 | import Data.Maybe 21 | 22 | import qualified Text.PrettyPrint as PP 23 | import Text.PrettyPrint (render,(<+>),hsep,punctuate,brackets,(<>),text,Doc) 24 | 25 | 26 | import GoTypes 27 | 28 | -- Pretty Printing -- 29 | 30 | class Pretty p where 31 | ppr :: (Applicative m, LFresh m) => p -> m Doc 32 | 33 | instance Pretty (Name a) where 34 | ppr = return . text . show 35 | 36 | dot = text "." 37 | bang = text "!" 38 | qmark = text "?" 39 | oplus = text "+" 40 | amper = text "&" 41 | tau = text "tau" 42 | 43 | instance Pretty GoType where 44 | ppr (Send c t) = do 45 | t' <- ppr t 46 | c' <- ppr c 47 | return $ c' <> bang <> PP.semi <> t' 48 | ppr (Recv c t) = do 49 | t' <- ppr t 50 | c' <- ppr c 51 | return $ c' <> qmark <> PP.semi <> t' 52 | ppr (Tau t) = do 53 | t' <- ppr t 54 | return $ tau <> PP.semi <> t' 55 | ppr (IChoice t1 t2) = do 56 | t1' <- ppr t1 57 | t2' <- ppr t2 58 | return $ oplus <> PP.braces (t1' <+> PP.comma <+> t2') 59 | ppr (OChoice l) = do 60 | l' <- mapM ppr l 61 | let prettyl = punctuate PP.comma l' 62 | return $ amper <> PP.braces (hsep prettyl) 63 | ppr (Par l) = do 64 | l' <- mapM ppr l 65 | let prettyl = punctuate (PP.space <> PP.text "|") l' 66 | return $ (hsep prettyl) 67 | ppr (New i bnd) = lunbind bnd $ \(c,t) -> do 68 | c' <- ppr c 69 | t' <- ppr t 70 | return $ PP.text "new" <+> (PP.int i) <+> c' <> dot <> (PP.parens t') 71 | ppr (Null) = return $ text "0" 72 | ppr (Close c t) = do 73 | t' <- ppr t 74 | c' <- ppr c 75 | return $ PP.text "close " <> c' <> PP.semi <> t' 76 | ppr (TVar x) = ppr x 77 | ppr (ChanInst t plist) = do 78 | t' <- ppr t 79 | l' <- mapM ppr plist 80 | let plist' = punctuate PP.comma l' 81 | return $ t' <+> PP.char '<' <> (hsep plist') <> PP.char '>' 82 | ppr (ChanAbst bnd) = lunbind bnd $ \(lc,t) -> do 83 | t' <- ppr t 84 | l' <- mapM ppr lc 85 | let plist' = punctuate PP.comma l' 86 | return $ brackets (hsep plist') <+> t' 87 | ppr (Seq l) = do 88 | l' <- mapM ppr l 89 | let plist = punctuate PP.semi l' 90 | return $ hsep plist 91 | ppr (Buffer c (open,i,j)) = do 92 | c' <- ppr c 93 | if open 94 | then return $ PP.text "[" <> c' <> PP.text ":" 95 | <> PP.text "B:" <> (PP.int i) 96 | <> PP.text "K:" <> (PP.int j) <> PP.text "]" 97 | else return $ PP.text "(" <> c' <> PP.text ":" 98 | <> PP.text "B:" <> (PP.int i) 99 | <> PP.text "K:" <> (PP.int j) <> PP.text ")" 100 | 101 | instance Pretty Eqn where 102 | ppr (EqnSys bnd) = lunbind bnd $ \(r,t) -> do 103 | t' <- ppr t 104 | let defs = unrec r 105 | pdefs <- mapM (\(n,Embed(t0)) -> do 106 | n' <- ppr n 107 | t0' <- ppr t0 108 | return $ n' <+> PP.text "=" <+> t0') defs 109 | let pdefs' = punctuate PP.comma pdefs 110 | return $ PP.braces (hsep pdefs') <+> PP.space <+> PP.text "in" <+> PP.space <+> t' 111 | 112 | -- Pretty printing conveniences -- 113 | 114 | pprintEqn :: Eqn -> String 115 | pprintEqn e = render . runLFreshM . ppr $ e 116 | 117 | pprintType :: GoType -> String 118 | pprintType t = render . runLFreshM . ppr $ t 119 | 120 | pprintTypeList :: [GoType] -> String 121 | pprintTypeList xs = L.foldr (\x -> \y -> x++"\n"++y) [] $ L.map pprintType xs 122 | 123 | ------- 124 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Gong [![Build Status](https://travis-ci.org/nickng/gong.svg?branch=master)](https://travis-ci.org/nickng/gong) [![Docker Hub](https://img.shields.io/badge/docker-ready-blue.svg)](https://hub.docker.com/r/nickng/gong/) 2 | 3 | ## Liveness and Safety checker for MiGo types 4 | 5 | ## Prerequisites 6 | 7 | - ghc version 7.10.3+ 8 | - cabal 9 | 10 | For Ubuntu Linux, `ghc` can be installed via `apt-get` as part of 11 | [**Haskell Platform**](https://www.haskell.org/platform/), and the 12 | packages can be installed via [**cabal**](https://www.haskell.org/cabal/). 13 | 14 | $ sudo apt-get install haskell-platform 15 | 16 | Then run cabal update: 17 | 18 | $ cabal update 19 | 20 | Finally, verify that `ghc` version is at least 7.10.1, for example: 21 | 22 | $ ghc --version 23 | The Glorious Glasgow Haskell Compilation System, version 7.10.3 24 | 25 | ## Install 26 | 27 | To build and install `Gong`, first download or checkout the source code: 28 | 29 | $ git clone https://github.com/nickng/gong.git 30 | 31 | Then build using the following command: 32 | 33 | $ cd gong; cabal install 34 | 35 | The built Gong binary can be found in `dist/build/Gong`, use the following to 36 | add to your current `$PATH`: 37 | 38 | $ export PATH=$PATH:$(pwd)/dist/build/Gong: 39 | 40 | ## Running 41 | 42 | To verify a given input `.migo` file, use the following command, which will 43 | output the result in the standard output: 44 | 45 | $ Gong -A path/to/file.migo 46 | Bound (k): 2 47 | Number of k-states: 4 48 | Liveness: True 49 | Safety: True 50 | 51 | To see all options available, use the `--help` flag. 52 | 53 | $ Gong --help 54 | 55 | Some further example `.migo` files are available under the `examples/` directory. 56 | 57 | ## Docker 58 | 59 | A Docker image is available for testing 60 | 61 | $ docker run nickng/gong:popl17ae Gong -A path/to/file.migo 62 | 63 | -------------------------------------------------------------------------------- /Safety.hs: -------------------------------------------------------------------------------- 1 | module Safety where 2 | 3 | import Liveness 4 | import GoTypes 5 | import SymbolicSem 6 | import Utils 7 | import PrettyGoTypes 8 | 9 | import Unbound.LocallyNameless 10 | import Unbound.LocallyNameless.Ops 11 | 12 | import Data.List as L 13 | import Data.Set as S (intersection, null, fromList) 14 | 15 | -- DEBUG 16 | import System.IO.Unsafe 17 | import Debug.Trace 18 | 19 | 20 | 21 | 22 | getContinuation :: GoType -> Maybe [GoType] 23 | getContinuation (Close c ty) = Just [ty, Buffer c (False, 0,0)] -- DEAL WITH BUFFER 24 | getContinuation _ = Nothing 25 | 26 | closebarbs :: GoType -> [GoType] 27 | closebarbs (Close c ty) = [Close c Null] 28 | closebarbs t = [] 29 | 30 | forbiddenAction :: GoType -> [GoType] 31 | forbiddenAction (Send n t) = [Send n Null] 32 | forbiddenAction (Close c ty) = [Close c Null] 33 | forbiddenAction (New i bnd) = let (c,ty) = unsafeUnbind bnd 34 | in forbiddenAction ty 35 | forbiddenAction (Par xs) = L.foldr (++) [] $ L.map forbiddenAction xs 36 | forbiddenAction t = [] 37 | 38 | 39 | badmatch :: GoType -> GoType -> Bool 40 | badmatch (Close c ty) (Send n t) = c == n 41 | badmatch (Close c ty) (Close n t) = c == n 42 | badmatch _ _ = False 43 | 44 | 45 | noclose :: [GoType] -> [GoType] -> Bool 46 | noclose [] [] = True 47 | noclose list@(x:xs) ys = 48 | let prod = cartProd list ys 49 | in L.null $ L.filter (\(x,y) -> badmatch x y) prod 50 | 51 | 52 | checkPair :: GoType -> GoType -> Bool 53 | checkPair t1 t2 = noclose (closebarbs t1) (forbiddenAction t2) 54 | 55 | 56 | checkList :: GoType -> [GoType] -> Bool 57 | checkList _ [] = True 58 | checkList current (x:xs) = if (checkPair current x) 59 | then (checkList current xs) 60 | else False -- error $ "Term no safe: "++(pprintType x) 61 | 62 | 63 | 64 | 65 | -- Given a parallel composition of type, check whether each 66 | -- one can make a move 67 | -- 68 | checkAllSuccs :: [ChName] -> Int -> Rec [(EqnName, Embed GoType)] -> [GoType] -> [GoType] -> M Bool 69 | checkAllSuccs names k sys prev [] = return True 70 | checkAllSuccs names k sys prev (x:next) = 71 | case getContinuation x of 72 | Just ty -> 73 | do let temp = succsNode k names (EqnSys $ bind sys (Par (prev++ty++next))) :: M [Eqn] 74 | nexts <- temp 75 | gotypes <- eqnToTypes temp 76 | rest <- (checkAllSuccs names k sys (prev++[x]) next) 77 | return $ (checkList x gotypes) && rest 78 | Nothing -> checkAllSuccs names k sys (prev++[x]) next 79 | 80 | 81 | 82 | 83 | 84 | safety :: Bool -> Int -> M [Eqn] -> M Bool 85 | safety debug k eqs = 86 | do list <- eqs 87 | case list of 88 | (sys@(EqnSys bnd):xs) -> 89 | do (defs, main) <- unbind bnd 90 | ty <- extractType (return main) 91 | let names = L.nub $ fv ty 92 | out <- checkAllSuccs names k defs [] ty 93 | if out 94 | then safety debug k $ return xs 95 | else if debug 96 | then error $ "Term not safe: " ++(show $ L.map pprintType ty) 97 | else return False 98 | [] -> return True 99 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /StuffParams.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | {-# LANGUAGE MultiParamTypeClasses 4 | , TemplateHaskell 5 | , ScopedTypeVariables 6 | , FlexibleInstances 7 | , FlexibleContexts 8 | , UndecidableInstances 9 | #-} 10 | 11 | 12 | import Unbound.LocallyNameless 13 | 14 | --import Control.Applicative 15 | import Control.Arrow ((+++)) 16 | import Control.Monad 17 | import Control.Monad.Trans.Maybe 18 | import Data.List as L 19 | import Data.Set as S 20 | import Data.Maybe 21 | -- import Control.Monad.Trans.Error 22 | 23 | import qualified Text.ParserCombinators.Parsec as P 24 | import Text.ParserCombinators.Parsec ((<|>),many) 25 | import qualified Text.ParserCombinators.Parsec.Token as T 26 | import Text.ParserCombinators.Parsec.Language 27 | 28 | import qualified Text.PrettyPrint as PP 29 | import Text.PrettyPrint (render,(<+>),hsep,punctuate,brackets,(<>),text,Doc) 30 | 31 | data Channel 32 | type ChName = Name Channel 33 | 34 | 35 | 36 | type EqnName = Name GoType 37 | 38 | 39 | data GoType = Send ChName GoType 40 | | Recv ChName GoType 41 | | Tau GoType 42 | | IChoice GoType GoType -- Just two things? 43 | | OChoice [GoType] 44 | | Par [GoType] 45 | | New (Bind ChName GoType) 46 | | Null 47 | | Close ChName GoType 48 | | TVar EqnName 49 | | ChanInst GoType [ChName] -- P(c) 50 | | ChanAbst (Bind [ChName] GoType) -- \c.P 51 | deriving Show 52 | 53 | 54 | 55 | data Eqn = EqnSys (Bind (Rec [(EqnName , Embed GoType)]) GoType) 56 | deriving Show 57 | -- inner Proc will always be ChanAbst 58 | 59 | $(derive [''Channel,''GoType,''Eqn]) 60 | 61 | --instance Alpha Channel 62 | instance Alpha GoType 63 | instance Alpha Eqn 64 | 65 | instance Subst GoType Eqn 66 | --instance Subst String GoType 67 | --instance Subst String Eqn 68 | 69 | instance Subst GoType GoType where 70 | isvar (TVar x) = Just (SubstName x) 71 | isvar _ = Nothing 72 | 73 | type M a = FreshM a 74 | 75 | -- Free name/var wrappers -- 76 | fnTyp :: GoType -> [ChName] 77 | fnTyp t = fv t 78 | 79 | fvTyp :: GoType -> [EqnName] 80 | fvTyp t = fv t 81 | 82 | fnEqn :: Eqn -> [ChName] 83 | fnEqn e = fv e 84 | 85 | fvEqn :: Eqn -> [EqnName] 86 | fvEqn e = fv e 87 | 88 | 89 | -- GoType Combinators (TVars, New, Chan Abs and Inst) -- 90 | tvar :: String -> GoType 91 | tvar = TVar . s2n 92 | 93 | new :: String -> GoType -> GoType 94 | new s t = New $ bind (s2n s) t 95 | 96 | chanAbst :: String -> GoType -> GoType 97 | chanAbst s t = ChanAbst $ bind ([s2n s]) t 98 | 99 | chanAbstL :: [String] -> GoType -> GoType 100 | chanAbstL l t = ChanAbst $ bind (L.map s2n l) t 101 | 102 | chanInst :: String -> String -> GoType 103 | chanInst s c = ChanInst (tvar s) ([s2n c]) 104 | 105 | chanInstL :: String -> [String] -> GoType 106 | chanInstL s l = ChanInst (tvar s) (L.map s2n l) 107 | 108 | ------------------------------ 109 | 110 | -- Equation System Combinators -- 111 | 112 | eqn' :: String -> GoType -> GoType -> Eqn 113 | eqn' s t1 t2 = EqnSys (bind (rec [(s2n s , Embed(t1) )]) t2) 114 | 115 | eqn :: String -> String -> GoType -> GoType -> Eqn 116 | eqn s c t1 t2 = eqn' s (chanAbst c t1) t2 117 | 118 | 119 | 120 | eqnl :: [(String,[String],GoType)] -> GoType -> Eqn 121 | eqnl l t = EqnSys (bind (rec (L.map (\(var,plist,def) -> 122 | (s2n var , Embed(chanAbstL plist def)) 123 | ) l)) t) 124 | 125 | ---------------------------------------- 126 | 127 | -- Structural Congruence -- 128 | 129 | -- Flatten out Pars in Par (i.e. T | (S | R) == (T | S) | R)-- 130 | flattenPar :: GoType -> GoType 131 | flattenPar (Par l) = Par (flattenPar' l) 132 | where flattenPar' (x:xs) = 133 | case x of 134 | Par l -> (flattenPar x):(flattenPar' xs) 135 | _ -> x:(flattenPar' xs) 136 | flattenPar' [] = [] 137 | flattenPar t = t 138 | 139 | -- Remove Nulls from Par (i.e. T | 0 == T)-- 140 | gcNull :: GoType -> GoType 141 | gcNull (Par l) = let res = gcNull' l in 142 | if (L.null res) then Null else Par res 143 | where gcNull' (x:xs) = 144 | case x of 145 | Null -> gcNull' xs 146 | _ -> x:(gcNull' xs) 147 | gcNull' [] = [] 148 | gcNull t = t 149 | 150 | -- GC unused bound names -- 151 | gcBNames' :: GoType -> M GoType 152 | gcBNames' (Send c t) = do 153 | t' <- gcBNames' t 154 | return $ Send c t' 155 | gcBNames' (Recv c t) = do 156 | t' <- gcBNames' t 157 | return $ Recv c t' 158 | gcBNames' (Tau t) = do 159 | t' <- gcBNames' t 160 | return $ Tau t' 161 | gcBNames' (IChoice t1 t2) = do 162 | t1' <- gcBNames' t1 163 | t2' <- gcBNames' t2 164 | return $ IChoice t1' t2' 165 | gcBNames' (OChoice l) = do 166 | lm' <- mapM gcBNames' l 167 | return $ OChoice lm' 168 | gcBNames' (Par l) = do 169 | lm' <- mapM gcBNames' l 170 | return $ Par lm' 171 | gcBNames' (New bnd) = do 172 | (c,t) <- unbind bnd 173 | t' <- gcBNames' t 174 | -- GC if c not used 175 | if c `S.notMember` fv t' 176 | then return t' 177 | else return (New (bind c t')) 178 | gcBNames' (Null) = return Null 179 | gcBNames' (Close c t) = do 180 | t' <- gcBNames' t 181 | return $ Close c t' 182 | gcBNames' (TVar x) = return $ TVar x 183 | gcBNames' (ChanInst t lc) = do -- P(~c) 184 | t' <- gcBNames' t 185 | return $ ChanInst t' lc 186 | gcBNames' (ChanAbst bnd) = do 187 | (c,t) <- unbind bnd 188 | t' <- gcBNames' t 189 | return $ ChanAbst (bind c t') 190 | 191 | 192 | gcBNames :: GoType -> GoType 193 | gcBNames = runFreshM . gcBNames' 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | -- Open top-level bound names in a list of parallel types -- 202 | -- return is a list of (mc,t) where mc is Nothing if t is 203 | -- closed and Just(c) otherwise. 204 | openBNames :: [GoType] -> M [(Maybe ChName,GoType)] 205 | openBNames l = do 206 | res <- openBNames' l 207 | return $ (init res) 208 | 209 | openBNames' (x:xs) = 210 | case x of 211 | New bnd -> do 212 | (c,t) <- unbind bnd 213 | rest <- openBNames' xs 214 | return $ (Just(c),t):rest 215 | _ -> do 216 | res <- openBNames' xs 217 | return $ (Nothing,x):res 218 | openBNames' [] = return $ [(Nothing,Null)] 219 | 220 | -- Reconstructs the appropriate GoType from calls 221 | -- to openBNames 222 | closeBNames :: M [(Maybe ChName,GoType)] -> M GoType 223 | closeBNames m = do 224 | l <- m 225 | let (names,ts) = unzip l 226 | return $ L.foldr (\mc end -> 227 | case mc of 228 | Just(c) -> New (bind c end) 229 | Nothing -> end) (Par ts) names 230 | 231 | -- Composes open/close and escapes the freshness monad -- 232 | pullBNamesPar :: GoType -> GoType 233 | pullBNamesPar (Par l) = 234 | runFreshM (closeBNames . openBNames $ l) 235 | pullBNamesPar t = t 236 | 237 | 238 | nf :: GoType -> GoType 239 | nf = id 240 | 241 | structCong :: GoType -> GoType -> Bool 242 | structCong t1 t2 = (nf t1) `aeq` (nf t2) 243 | 244 | 245 | ----------- 246 | 247 | 248 | -- Pretty Printing -- 249 | 250 | class Pretty p where 251 | ppr :: (Applicative m, LFresh m) => p -> m Doc 252 | 253 | instance Pretty (Name a) where 254 | ppr = return . text . show 255 | 256 | dot = text "." 257 | bang = text "!" 258 | qmark = text "?" 259 | oplus = text "+" 260 | amper = text "&" 261 | tau = text "tau" 262 | 263 | instance Pretty GoType where 264 | ppr (Send c t) = do 265 | t' <- ppr t 266 | c' <- ppr c 267 | return $ c' <> bang <> PP.semi <> t' 268 | ppr (Recv c t) = do 269 | t' <- ppr t 270 | c' <- ppr c 271 | return $ c' <> qmark <> PP.semi <> t' 272 | ppr (Tau t) = do 273 | t' <- ppr t 274 | return $ tau <> PP.semi <> t' 275 | ppr (IChoice t1 t2) = do 276 | t1' <- ppr t1 277 | t2' <- ppr t2 278 | return $ oplus <> PP.braces (t1' <+> PP.comma <+> t2') 279 | ppr (OChoice l) = do 280 | l' <- mapM ppr l 281 | let prettyl = punctuate PP.comma l' 282 | return $ amper <> PP.braces (hsep prettyl) 283 | ppr (Par l) = do 284 | l' <- mapM ppr l 285 | let prettyl = punctuate (PP.text "|") l' 286 | return $ (hsep prettyl) 287 | ppr (New bnd) = lunbind bnd $ \(c,t) -> do 288 | c' <- ppr c 289 | t' <- ppr t 290 | return $ PP.text "new" <+> c' <> dot <> (PP.parens t') 291 | ppr (Null) = return $ text "0" 292 | ppr (Close c t) = do 293 | t' <- ppr t 294 | c' <- ppr c 295 | return $ PP.text "close " <> c' <> PP.semi <> t' 296 | ppr (TVar x) = ppr x 297 | ppr (ChanInst t plist) = do 298 | t' <- ppr t 299 | l' <- mapM ppr plist 300 | let plist' = punctuate PP.comma l' 301 | return $ t' <+> PP.char '<' <> (hsep plist') <> PP.char '>' 302 | ppr (ChanAbst bnd) = lunbind bnd $ \(lc,t) -> do 303 | t' <- ppr t 304 | l' <- mapM ppr lc 305 | let plist' = punctuate PP.comma l' 306 | return $ brackets (hsep plist') <+> t' 307 | 308 | instance Pretty Eqn where 309 | ppr (EqnSys bnd) = lunbind bnd $ \(r,t) -> do 310 | t' <- ppr t 311 | let defs = unrec r 312 | pdefs <- mapM (\(n,Embed(t0)) -> do 313 | n' <- ppr n 314 | t0' <- ppr t0 315 | return $ n' <+> PP.text "=" <+> t0') defs 316 | let pdefs' = punctuate PP.comma pdefs 317 | return $ PP.braces (hsep pdefs') <+> PP.space <+> PP.text "in" <+> PP.space <+> t' 318 | 319 | -- Pretty printing conveniences -- 320 | 321 | pprintEqn :: Eqn -> String 322 | pprintEqn e = render . runLFreshM . ppr $ e 323 | 324 | pprintType :: GoType -> String 325 | pprintType t = render . runLFreshM . ppr $ t 326 | 327 | ------- 328 | 329 | -- Lexer -- 330 | lexer :: T.TokenParser () 331 | 332 | ldef = emptyDef { T.identStart = P.letter 333 | , T.identLetter = P.alphaNum 334 | , T.reservedNames = [ "def" 335 | , "call" 336 | , "close" 337 | , "spawn" 338 | , "let" 339 | , "newchan" 340 | , "select" 341 | , "case" 342 | , "endselect" 343 | , "if" 344 | , "else" 345 | , "endif" 346 | , "tau" 347 | , "send" 348 | , "recv" ] } 349 | 350 | lexer = T.makeTokenParser ldef 351 | 352 | whiteSpace = T.whiteSpace lexer 353 | reserved = T.reserved lexer 354 | parens = T.parens lexer 355 | identifier = T.identifier lexer 356 | natural = T.natural lexer 357 | integer = T.integer lexer 358 | semi = T.semi lexer 359 | symbol = T.symbol lexer 360 | 361 | -- Parser -- 362 | 363 | data Prog = P [Def] 364 | deriving (Eq, Show) 365 | 366 | data Def = D String [String] Interm 367 | deriving (Eq, Show) 368 | 369 | data Interm = Seq [Interm] 370 | | Call String [String] 371 | | Cl String 372 | | Spawn String [String] 373 | | NewChan String String Integer 374 | | If Interm Interm 375 | | Select [Interm] 376 | | T 377 | | S String 378 | | R String 379 | | Zero 380 | deriving (Eq, Show) 381 | 382 | seqInterm :: P.Parser Interm 383 | seqInterm = do 384 | list <- P.sepBy1 itparser semi 385 | return $ if L.length list == 1 then head list else Seq list 386 | 387 | pparser :: P.Parser Prog 388 | pparser = do 389 | l <- many dparser 390 | return $ P l 391 | 392 | 393 | dparser :: P.Parser Def 394 | dparser = do 395 | { reserved "def" 396 | ; x <- identifier 397 | ; list <- parens (P.sepBy1 identifier (P.char ',')) 398 | ; symbol ":" 399 | ; d <- seqInterm 400 | ; return $ D x list d 401 | } 402 | 403 | 404 | itparser :: P.Parser Interm 405 | itparser = 406 | do { reserved "close" 407 | ; c <- identifier 408 | ; return $ (Cl c) } 409 | <|> 410 | do { reserved "spawn" 411 | ; x <- identifier 412 | ; list <- parens (P.sepBy1 identifier (P.char ',')) 413 | ; return $ Spawn x list } 414 | <|> 415 | do { reserved "select" 416 | ; l <- many (reserved "case" *> seqInterm) 417 | ; reserved "endselect" 418 | ; return $ Select l } 419 | <|> 420 | do { reserved "let" 421 | ; x <- identifier 422 | ; symbol "=" 423 | ; reserved "newchan" 424 | ; t <- identifier 425 | ; n <- natural 426 | ; return $ NewChan x t n } 427 | <|> 428 | do { reserved "if" 429 | ; t <- seqInterm 430 | ; reserved "else" 431 | ; e <- seqInterm 432 | ; reserved "endif" 433 | ; return $ If t e } 434 | <|> 435 | do { reserved "tau" 436 | ; return $ T } 437 | <|> 438 | do { reserved "send" 439 | ; c <- identifier 440 | ; return $ S c } 441 | <|> 442 | do { reserved "recv" 443 | ; c <- identifier 444 | ; return $ R c } 445 | <|> 446 | do { reserved "call" 447 | ; c <- identifier 448 | ; list <- parens (P.sepBy1 identifier (P.char ',')) 449 | ; return $ Call c list } 450 | <|> 451 | do { return $ Zero } 452 | 453 | mainparser :: P.Parser Prog 454 | mainparser = whiteSpace >> pparser <* P.eof 455 | 456 | parseprog :: String -> Either P.ParseError Prog 457 | parseprog inp = P.parse mainparser "" inp 458 | 459 | parseTest s = 460 | case parseprog s of 461 | Left err -> print err 462 | Right s -> print s 463 | 464 | ------- 465 | 466 | 467 | -- Once unfoldings of GoTypes and EquationSys -- 468 | 469 | unfoldType :: GoType -> M GoType 470 | unfoldType (Send c t) = do 471 | t' <- unfoldType t 472 | return $ Send c t' 473 | unfoldType (Recv c t) = do 474 | t' <- unfoldType t 475 | return $ Recv c t' 476 | 477 | unfoldType (Tau t) = do 478 | t' <- unfoldType t 479 | return $ Tau t' 480 | unfoldType (IChoice t1 t2) = do 481 | t1' <- unfoldType t1 482 | t2' <- unfoldType t2 483 | return $ IChoice t1' t2' 484 | unfoldType (OChoice l) = do 485 | lm' <- mapM unfoldType l 486 | return $ OChoice lm' 487 | unfoldType (Par l) = do 488 | lm' <- mapM unfoldType l 489 | return $ Par lm' 490 | unfoldType (New bnd) = do 491 | (c,t) <- unbind bnd 492 | t' <- unfoldType t 493 | -- GC if c not used 494 | if c `S.notMember` fv t' 495 | then return t' 496 | else return (New (bind c t')) 497 | unfoldType (Null) = return Null 498 | unfoldType (Close c t) = do 499 | t' <- unfoldType t 500 | return $ Close c t' 501 | unfoldType (TVar x) = return $ TVar x 502 | unfoldType (ChanInst t lc) = do -- P(~c) 503 | t' <- unfoldType t 504 | case t' of 505 | ChanAbst bnd -> do -- P == (\~d.P)(~c) 506 | (ld,t0) <- unbind bnd 507 | let perm = L.foldr (\(d,c) acc -> compose acc (single (AnyName d) (AnyName c)) ) (Unbound.LocallyNameless.empty) (zip ld lc) 508 | return $ swaps perm t0 509 | otherwise -> return $ ChanInst t' lc 510 | unfoldType (ChanAbst bnd) = do 511 | (c,t) <- unbind bnd 512 | t' <- unfoldType t 513 | return $ ChanAbst (bind c t') 514 | 515 | 516 | 517 | unfoldEqn :: Eqn -> M Eqn 518 | unfoldEqn (EqnSys bnd) = do 519 | (r,body) <- unbind bnd 520 | let vars = unrec r 521 | let newbody = L.foldr (\(x,Embed rhs) body -> subst x rhs body) body vars 522 | return $ EqnSys (bind (rec vars) newbody) 523 | 524 | unfoldTop :: Eqn -> M Eqn 525 | unfoldTop (EqnSys bnd) = do 526 | (r,body) <- unbind bnd 527 | let vars = unrec r 528 | let newbody = L.foldr (\(x,Embed rhs) body -> subst x rhs body) body vars 529 | bla <- unfoldType newbody 530 | return $ EqnSys (bind (rec vars) bla) 531 | 532 | 533 | 534 | ---- Testing Area: Please stand back ----- 535 | simpleEx = eqn "t" "c" (Send (s2n "c") (new "d" (chanInst "t" "d"))) (chanInst "t" "c") 536 | 537 | 538 | 539 | 540 | twored = do 541 | t <- unfoldTop simpleEx 542 | unfoldTop t 543 | 544 | twored' = do 545 | t <- twored 546 | return $ pprintEqn t 547 | 548 | -- -- Testing stuff -- 549 | 550 | --eqnl :: [(String,[String],GoType)] -> GoType -> Eqn 551 | --eqnl l t = EqnSys (bind (rec (map (\(s,c,t1) -> (string2Name s ,Embed(bind (map string2Name c) t1) )) l)) t) 552 | 553 | --testSubst = tvar "s" "c" 554 | 555 | -- test1 = eqn "t" "c" (Send (namify "c") (tvar "t" "c")) (new "c" (tvar "t" "c")) 556 | 557 | -- -- Testing re-use of a in eq s. Should be free [OK] 558 | -- test2 = eqnl [("t",["a"] , (Send (namify "a") (tvar "t" "a")) ) , 559 | -- ("s" ,["b"] ,(Recv (namify "a") (tvar "s" "b")) ) ] (new "c" (Par (tvar "t" "c") (tvar "s" "c"))) 560 | 561 | -- -- Baseline for recursive stuff [OK] 562 | -- test3 = eqnl [("t",["a"] , (Send (namify "a") (tvar "t" "a")) ) , 563 | -- ("s" ,["b"] ,(Recv (namify "b") (tvar "s" "b")) ) ] (new "c" (Par (tvar "t" "c") (tvar "s" "c"))) 564 | 565 | -- -- Testing mutually recursive binders [OK] 566 | -- test4 = eqnl [("t",["a"] , (Send (namify "a") (tvar "s" "a")) ) , 567 | -- ("s" ,["b"] ,(Recv (namify "b") (tvar "t" "b")) ) ] (new "c" (Par (tvar "t" "c") (tvar "s" "c"))) 568 | 569 | -- -- Testing for free "a" in main [OK] 570 | -- test5 = eqnl [("t",["a"] , (Send (namify "a") (tvar "t" "a")) ) , 571 | -- ("s" ,["b"] ,(Recv (namify "b") (tvar "s" "b")) ) ] (new "c" (Par (tvar "t" "a") (tvar "s" "c"))) 572 | 573 | -- -- Testing for free rec var in main [OK] 574 | -- test6 = eqnl [("t",["a"] , (Send (namify "a") (tvar "t" "a")) ) , 575 | -- ("s" ,["b"] ,(Recv (namify "b") (tvar "s" "b")) ) ] (new "c" (Par (tvar "d" "a") (tvar "s" "c"))) 576 | 577 | -- -- All should be aeq to test3 [OK All] 578 | -- test3aeq1 = eqnl [("t",["a"] , (Send (namify "a") (tvar "t" "a")) ) , 579 | -- ("s" ,["b"] ,(Recv (namify "b") (tvar "s" "b")) ) ] (new "d" (Par (tvar "t" "d") (tvar "s" "d"))) 580 | 581 | -- test3aeq2 = eqnl [("xpto",["a"] , (Send (namify "a") (tvar "xpto" "a")) ) , 582 | -- ("s" ,["b"] ,(Recv (namify "b") (tvar "s" "b")) ) ] (new "d" (Par (tvar "xpto" "d") (tvar "s" "d"))) 583 | 584 | -- test3aeq3 = eqnl [("t",["b"] , (Send (namify "b") (tvar "t" "b")) ) , 585 | -- ("s" ,["b"] ,(Recv (namify "b") (tvar "s" "b")) ) ] (new "d" (Par (tvar "t" "d") (tvar "s" "d"))) 586 | 587 | -- -- Won't be 588 | -- test3aeq4 = eqnl [("s" ,["b"] ,(Recv (namify "b") (tvar "s" "b")) ) , 589 | -- ("t",["a"] , (Send (namify "a") (tvar "t" "a")) ) ] (new "c" (Par (tvar "t" "c") (tvar "s" "c"))) 590 | 591 | -- Unfolding Test -- 592 | 593 | 594 | --(Bind (Rec [(Name GoType, Embed (Bind [Name String] GoType))]) GoType) 595 | 596 | 597 | 598 | assert :: String -> Bool -> IO () 599 | assert s True = return () 600 | assert s False = print ("Assertion " ++ s ++ " failed") 601 | 602 | --eqn :: String -> GoType -> GoType -> Eqn 603 | --eqn s t1 t2 = EqnSys (bind (rec (string2Name s , Embed(t1) )) t2) 604 | 605 | 606 | --eqnSys :: [(String,GoType)] -> GoType -> Eqn 607 | --eqnSys l t2 = EqnSys (bind (rec ( map (\(s,t1) -> (string2Name s, Embed(t1))) l )) t2) 608 | 609 | 610 | 611 | -------------------------------------------------------------------------------- /SymbolicSem.hs: -------------------------------------------------------------------------------- 1 | module SymbolicSem where 2 | 3 | import GoTypes 4 | import PrettyGoTypes (pprintEqn, pprintType) 5 | import Utils 6 | import TypeSize 7 | 8 | import Unbound.LocallyNameless 9 | import Unbound.LocallyNameless.Ops 10 | 11 | import Data.List as L 12 | import Data.Set as S (intersection, null, fromList) 13 | 14 | -- DEBUG 15 | import System.IO.Unsafe 16 | import Debug.Trace 17 | 18 | 19 | 20 | 21 | 22 | 23 | inList :: GoType -> [GoType] -> Bool 24 | inList t [] = False 25 | inList t (x:xs) = (t `aeq` x) || (inList t xs) 26 | 27 | 28 | 29 | 30 | 31 | symCondition :: [ChName] -> [ChName] -> Bool 32 | symCondition m [] = False 33 | symCondition m b = S.null $ intersection (fromList m) (fromList b) 34 | 35 | 36 | 37 | normalise :: Int -> [ChName] -> Environment -> GoType -> GoType 38 | normalise k names defEnv ty = 39 | let t1 = nfUnfold k names [] defEnv ty 40 | in runFreshM $ nf (gcBuffer . initiate $ t1) 41 | 42 | 43 | nfUnfold :: Int -> [ChName] -> [EqnName] -> Environment -> GoType -> M GoType 44 | nfUnfold k m seen defEnv t = 45 | unfoldTillGuard k m seen defEnv t 46 | 47 | unfoldTillGuard :: Int -> [ChName] -> [EqnName] -> Environment -> GoType -> M GoType 48 | unfoldTillGuard k m seen defEnv (Par xs) = 49 | do ys <- (sequence (map (unfoldTillGuard k m seen defEnv) xs)) 50 | return $ Par ys 51 | unfoldTillGuard k m seen defEnv ori@(ChanInst (TVar t) lc) 52 | | (symCondition m lc) || (t `L.elem` seen) = return ori 53 | | otherwise = 54 | case L.lookup t defEnv of 55 | Just (Embed ty) -> 56 | case ty of 57 | ChanAbst bnd -> 58 | do (ld,t0) <- unbind bnd 59 | let perm = L.foldr 60 | (\(d,c) acc -> compose acc (single (AnyName d) (AnyName c))) 61 | (Unbound.LocallyNameless.empty) (zip ld lc) 62 | unfoldTillGuard k m (t:seen) defEnv $ swaps perm t0 63 | _ -> return ty 64 | _ -> error $ "[unfoldTillGuard]Definition "++(show t)++" not found."++(show defEnv) 65 | unfoldTillGuard k m seen defEnv (New i bnd) = 66 | do (c,ty) <- unbind bnd 67 | nty <- let nm = if (length m) < k then c:m 68 | else m 69 | in unfoldTillGuard k nm seen defEnv ty 70 | return $ New i (bind c nty) 71 | unfoldTillGuard k m seen defEnv (ChanAbst bnd) = 72 | do (c,ty) <- unbind bnd 73 | nty <- unfoldTillGuard k m seen defEnv ty 74 | return $ ChanAbst (bind c nty) 75 | unfoldTillGuard k m seen defEnv (Seq xs) = case xs of 76 | [x] -> unfoldTillGuard k m seen defEnv x 77 | [x,Null] -> unfoldTillGuard k m seen defEnv x 78 | otherwise -> error $ "[unfoldTillGuard] We don't deal with Seq yet: \n"++(pprintType $ Seq xs) 79 | unfoldTillGuard k m seen defEnv t = return t 80 | 81 | isTau :: GoType -> Bool 82 | isTau (Tau t) = True 83 | isTau t = False 84 | 85 | getFreePars :: GoType -> M [GoType] 86 | getFreePars (New i bnd) = do (c,ty) <- unbind bnd 87 | getFreePars ty 88 | getFreePars (Par xs) = return $ xs 89 | getFreePars t = return $ [t] 90 | 91 | 92 | getGuardsCont :: GoType -> [(GoType, GoType)] 93 | getGuardsCont (Send n t) = [(Send n Null, t)] 94 | getGuardsCont (Recv n t) = [(Recv n Null, t)] 95 | getGuardsCont (Tau t) = [(Tau Null, t)] 96 | getGuardsCont (IChoice t1 t2) = [(Tau Null, t1), (Tau Null, t2)] 97 | getGuardsCont (OChoice xs) = L.foldr (++) [] $ map getGuardsCont xs 98 | getGuardsCont (Close c ty) = [(Close c Null, ty)] 99 | getGuardsCont (Buffer c (open,b,k)) 100 | | (b==0 && k==0)= [(ClosedBuffer c, Buffer c (False,b,k))] 101 | | (k < b) && (k > 0) = [ (Send c Null, Buffer c (open,b,k-1)) 102 | , (Recv c Null, Buffer c (open,b,k+1)) 103 | , (ClosedBuffer c, Buffer c (False,b,k)) 104 | ] 105 | | k > 0 = [(Send c Null, Buffer c (open,b,k-1)) 106 | , (ClosedBuffer c, Buffer c (False,b,k)) 107 | ] 108 | | k < b = [(Recv c Null, Buffer c (open,b,k+1)) 109 | , (ClosedBuffer c, Buffer c (False,b,k)) 110 | ] 111 | | not open = [(Send c Null, Buffer c (open,b,k-1)) 112 | , (ClosedBuffer c, Buffer c (False,b,k)) 113 | ] 114 | | otherwise = [] 115 | getGuardsCont _ = [] 116 | 117 | 118 | 119 | 120 | 121 | compatibleConts :: [(GoType, GoType)] -> [(GoType, GoType)] -> [(GoType, GoType)] 122 | compatibleConts xs ys = 123 | let prod = cartProd xs ys 124 | compa ((g1,t1), (g2,t2)) = match g1 g2 125 | in L.map (\((g1,t1),(g2,t2)) -> (t1,t2)) $ 126 | L.filter compa prod 127 | 128 | 129 | 130 | match :: GoType -> GoType -> Bool 131 | match ((Send c1 _)) ((Recv c2 _)) = c1 == c2 132 | match ((Recv c2 _)) ((Send c1 _)) = c1 == c2 133 | match ((Close c _)) ((ClosedBuffer c')) = c == c' 134 | match _ _ = False 135 | 136 | 137 | tauGuards :: [(GoType, GoType)] -> [(GoType, GoType)] 138 | tauGuards xs = L.filter (\(x,y) -> isTau x) xs 139 | 140 | blockingGuards :: [(GoType, GoType)] -> [(GoType, GoType)] 141 | blockingGuards xs = L.filter (\(x,y) -> not $ isTau x) xs 142 | 143 | 144 | succsOf :: [(GoType, GoType)] -> [GoType] -> [GoType] -> [[GoType]] 145 | succsOf guards prevPar [] = [] 146 | succsOf guards prevPar (x:xs) = let coguards = blockingGuards $ getGuardsCont x 147 | next = compatibleConts guards coguards 148 | in 149 | ( 150 | L.map 151 | (\(t1,t2) -> [t1]++prevPar++[t2]++xs) 152 | next 153 | ) 154 | ++ 155 | (succsOf guards (prevPar++[x]) xs) 156 | 157 | genParSuccs :: [GoType] -> [GoType] -> [[GoType]] 158 | genParSuccs _ [] = [] 159 | genParSuccs prev (x:xs) = 160 | let guards = getGuardsCont x 161 | bguards = blockingGuards guards 162 | tauguards = tauGuards guards 163 | tausuccs = 164 | L.map (\x -> prev++[x]++xs) (L.map (\(g,t) -> t) tauguards) 165 | in (succsOf bguards prev xs) 166 | ++ 167 | tausuccs 168 | ++ 169 | (genParSuccs (prev++[x]) xs) 170 | 171 | 172 | 173 | 174 | 175 | genSuccs :: Environment -> GoType -> M [GoType] 176 | genSuccs defEnv (New i bnd) = do (c,ty) <- unbind bnd 177 | ret <- (genSuccs defEnv ty) 178 | return $ L.map (\t -> New i $ bind c t) ret 179 | genSuccs defEnv (Par xs) = return $ L.map (\x -> Par x) $ genParSuccs [] xs 180 | genSuccs defEnvt t = return $ L.map (\x -> Par x) $ genParSuccs [] [t] 181 | 182 | 183 | genStates :: Int -> [ChName] -> Environment -> [GoType] -> [GoType] -> M [GoType] 184 | genStates k names env seen [] = return seen 185 | genStates k names env seen (x:xs) 186 | | x `inList` seen = genStates k names env seen xs 187 | | otherwise = do 188 | next <- genSuccs env x 189 | genStates k names env (x:seen) (xs++(L.map (normalise k names env) next)) 190 | 191 | 192 | succs :: Int -> Eqn -> M [Eqn] 193 | succs bound sys = succsNode bound [] sys 194 | 195 | succsNode :: Int -> [ChName] -> Eqn -> M [Eqn] 196 | succsNode bound names sys@(EqnSys bnd) = 197 | let k = if L.null names then bound else length names 198 | in do (defs,main) <- unbind bnd 199 | states <- genStates k names (unrec defs) [] 200 | [(normalise k names (unrec defs) main)] 201 | return $ L.map (\x -> EqnSys $ bind defs x) (states :: [GoType]) 202 | 203 | 204 | 205 | 206 | extractType :: M GoType -> M [GoType] 207 | extractType ty = 208 | do ty' <- ty 209 | case ty' of 210 | (New i bnd) -> if (i==(-1)) 211 | then do (c,t) <- unbind bnd 212 | extractType (return t) 213 | else error $ "[extractType]Channels not initiated: "++(pprintType ty') 214 | (Par xs) -> return xs 215 | otherwise -> return [ty'] 216 | 217 | initiate :: M GoType -> M GoType 218 | initiate t = do t' <- t 219 | initiateChannels t' 220 | 221 | initiateChannels :: GoType -> M GoType 222 | initiateChannels (New i bnd) = 223 | do (c,t) <- unbind bnd 224 | ty <- initiateChannels t 225 | return $ if (i == -1) 226 | then New i $ bind c ty -- no buffer if already created 227 | else New (-1) $ bind c (Par [ty, Buffer c (True,i,0)]) 228 | initiateChannels (Send c t) = do t' <- initiateChannels t 229 | return $ Send c t' 230 | initiateChannels (Recv c t) = do t' <- initiateChannels t 231 | return $ Recv c t' 232 | initiateChannels (Tau t) = do t' <- initiateChannels t 233 | return $ Tau t' 234 | initiateChannels (IChoice t1 t2) = 235 | do t1' <- initiateChannels t1 236 | t2' <- initiateChannels t2 237 | return $ IChoice t1' t2' 238 | initiateChannels (OChoice xs) = 239 | do ts <- mapM initiateChannels xs 240 | return $ OChoice ts 241 | initiateChannels (Par xs) = 242 | do ts <- mapM initiateChannels xs 243 | return $ Par ts 244 | initiateChannels Null = return Null 245 | initiateChannels (Close c t) = do t' <- initiateChannels t 246 | return $ Close c t' 247 | initiateChannels (TVar x) = return $ TVar x 248 | initiateChannels (Buffer c s) = return $ Buffer c s 249 | initiateChannels (ChanInst t lc) = do t' <- initiateChannels t 250 | return $ ChanInst t' lc 251 | initiateChannels (ChanAbst bnd) = 252 | do (c,t) <- unbind bnd 253 | t' <- initiateChannels t 254 | return $ ChanAbst $ bind c t' 255 | initiateChannels (Seq [t]) = initiateChannels t 256 | initiateChannels (Seq [t,Null]) = initiateChannels t 257 | initiateChannels (Seq xs) = case last xs of 258 | Null -> initiateChannels (Seq $ init xs) 259 | otherwise -> error $ "[initiateChannels] We don't deal with full Seq yet: " 260 | ++(show $ L.map pprintType xs) 261 | 262 | -------------------------------------------------------------------------------- /TypeSize.hs: -------------------------------------------------------------------------------- 1 | module TypeSize where 2 | 3 | 4 | import GoTypes 5 | import PrettyGoTypes (pprintEqn, pprintType) 6 | import Utils 7 | 8 | import Unbound.LocallyNameless 9 | import Unbound.LocallyNameless.Ops 10 | 11 | import Data.List as L 12 | -- import Data.Set as S (intersection, null) 13 | 14 | -- DEBUG 15 | import System.IO.Unsafe 16 | import Debug.Trace 17 | 18 | type Environment = [(EqnName , Embed GoType)] 19 | 20 | symsemBound :: [EqnName] -> Environment -> GoType -> Int 21 | symsemBound seen defEnv (Send _ ty) = symsemBound seen defEnv ty 22 | symsemBound seen defEnv (Recv _ ty) = symsemBound seen defEnv ty 23 | symsemBound seen defEnv (Tau ty) = symsemBound seen defEnv ty 24 | symsemBound seen defEnv (IChoice ty1 ty2) = 25 | maximum [symsemBound seen defEnv ty1, symsemBound seen defEnv ty2] 26 | symsemBound seen defEnv (OChoice xs) = maximum (map (symsemBound seen defEnv) xs) 27 | symsemBound seen defEnv (Par xs) = maximum (map (symsemBound seen defEnv) xs) 28 | symsemBound seen defEnv (New i bnd) = let (c,ty) = unsafeUnbind bnd 29 | in 1 + symsemBound seen defEnv ty 30 | symsemBound seen defEnv (Null) = 0 31 | symsemBound seen defEnv (Close _ ty) = symsemBound seen defEnv ty 32 | symsemBound seen defEnv (ChanInst (TVar t) xs) 33 | | t `L.elem` seen = 0 34 | | otherwise = 35 | case L.lookup t defEnv of 36 | Just (Embed ty) -> symsemBound (t:seen) defEnv ty 37 | _ -> error $ "[symsemBound]Definition "++(show t)++" not found." 38 | symsemBound seen defEnv (ChanAbst bnd) = let (c,ty) = unsafeUnbind bnd 39 | in symsemBound seen defEnv ty 40 | symsemBound seen defEnv (Seq xs) = sum (map (symsemBound seen defEnv) xs) 41 | symsemBound seen defEnv (TVar eqs) = error "[symsemBound]TVAR" 42 | 43 | 44 | 45 | 46 | sizeOfT :: [EqnName] -> Environment -> GoType -> Int 47 | sizeOfT seen defEnv (Send _ ty) = 1 + (sizeOfT seen defEnv ty) 48 | sizeOfT seen defEnv (Recv _ ty) = 1 + (sizeOfT seen defEnv ty) 49 | sizeOfT seen defEnv (Tau ty) = sizeOfT seen defEnv ty 50 | sizeOfT seen defEnv (IChoice ty1 ty2) = 51 | maximum [sizeOfT seen defEnv ty1, sizeOfT seen defEnv ty2] 52 | sizeOfT seen defEnv (OChoice xs) = maximum (map (sizeOfT seen defEnv) xs) 53 | sizeOfT seen defEnv (Par xs) = L.foldr (+) 0 (map (sizeOfT seen defEnv) xs) 54 | sizeOfT seen defEnv (New i bnd) = let (c,ty) = unsafeUnbind bnd 55 | in sizeOfT seen defEnv ty 56 | sizeOfT seen defEnv (Null) = 0 57 | sizeOfT seen defEnv (Close _ ty) = sizeOfT seen defEnv ty 58 | sizeOfT seen defEnv (ChanInst (TVar t) xs) 59 | | t `L.elem` seen = 0 60 | | otherwise = 61 | case L.lookup t defEnv of 62 | Just (Embed ty) -> sizeOfT (t:seen) defEnv ty 63 | _ -> error $ "[sizeOfT]Definition "++(show t)++" not found." 64 | sizeOfT seen defEnv (ChanAbst bnd) = let (c,ty) = unsafeUnbind bnd 65 | in sizeOfT seen defEnv ty 66 | sizeOfT seen defEnv (Seq xs) = sum (map (sizeOfT seen defEnv) xs) 67 | sizeOfT seen defEnv (TVar eqs) = error "[sizeOfT]TVAR" 68 | 69 | 70 | isRecPar :: [EqnName] -> Environment -> GoType -> Int 71 | isRecPar seen defEnv (Send _ ty) = isRecPar seen defEnv ty 72 | isRecPar seen defEnv (Recv _ ty) = isRecPar seen defEnv ty 73 | isRecPar seen defEnv (Tau ty) = isRecPar seen defEnv ty 74 | isRecPar seen defEnv (IChoice ty1 ty2) = 75 | maximum [isRecPar seen defEnv ty1, isRecPar seen defEnv ty2] 76 | isRecPar seen defEnv (OChoice xs) = maximum (map (isRecPar seen defEnv) xs) 77 | 78 | isRecPar seen defEnv (Par xs) = 79 | let (recs, notrecs) = partition (\x -> not $ L.null $ intersect seen (fvTyp x)) xs 80 | sizes = L.map (sizeOfT [] defEnv) notrecs 81 | in if L.null recs 82 | then 0 83 | else maximum (0:sizes) 84 | isRecPar seen defEnv (New i bnd) = let (c,ty) = unsafeUnbind bnd 85 | in isRecPar seen defEnv ty 86 | isRecPar seen defEnv (Null) = 0 87 | isRecPar seen defEnv (Close _ ty) = isRecPar seen defEnv ty 88 | isRecPar seen defEnv (ChanInst (TVar t) xs) 89 | | t `L.elem` seen = 0 90 | | otherwise = 91 | case L.lookup t defEnv of 92 | Just (Embed ty) -> isRecPar (t:seen) defEnv ty 93 | _ -> error $ "[isRecPar]Definition "++(show t)++" not found." 94 | isRecPar seen defEnv (ChanAbst bnd) = let (c,ty) = unsafeUnbind bnd 95 | in isRecPar seen defEnv ty 96 | isRecPar seen defEnv (Seq xs) = sum (map (isRecPar seen defEnv) xs) 97 | isRecPar seen defEnv (TVar eqs) = error "[isRecPar]TVAR" 98 | 99 | 100 | maxnestednames :: Eqn -> Int 101 | maxnestednames (EqnSys bnd) = let (defs,main) = unsafeUnbind bnd 102 | in symsemBound [] (unrec defs) main 103 | 104 | sizeOfEqs :: Eqn -> Int 105 | sizeOfEqs (EqnSys bnd) = 106 | let (defs,main) = unsafeUnbind bnd 107 | deflist = unrec defs 108 | fun (n,(Embed (ChanAbst bnd))) = let (l,t) = unsafeUnbind bnd 109 | in isRecPar [n] (unrec defs) t 110 | in maximum (0:(L.map fun deflist)) 111 | -------------------------------------------------------------------------------- /Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils where 2 | 3 | cartProd :: [a] -> [b] -> [(a,b)] 4 | cartProd xs ys = [(x,y) | x <- xs, y <- ys] 5 | -------------------------------------------------------------------------------- /examples/async-chans.cgo: -------------------------------------------------------------------------------- 1 | -- This example illustrates the use of asynchronous channels (bound > 2 | -- 0), this example is live and safe. 3 | -- Note that if we were to change both buffers sized to 0, the 4 | -- exampe would not be lived. 5 | 6 | def t0() : let a = newchan ty, 0 ; -- buffer size = 1 7 | let b = newchan ty, 1 ; -- buffer size = 1 8 | spawn t1(a,b); 9 | spawn t1(b,a); 10 | 11 | def t1(x,y): send x; recv y; 12 | 13 | -------------------------------------------------------------------------------- /examples/closing-chan.cgo: -------------------------------------------------------------------------------- 1 | -- This example illustrates synchronisation with a closed channel 2 | -- it is live and safe. 3 | -- 4 | def t0() : let a = newchan ty, 0 ; 5 | close a; 6 | if 7 | recv a; 8 | else 9 | tau; 10 | -- close a; -- if uncommented this example is NOT safe 11 | endif; -------------------------------------------------------------------------------- /examples/dining-philo.cgo: -------------------------------------------------------------------------------- 1 | -- This example models the 3 dinning philosophers 2 | -- it is live and safe 3 | -- (+/- 13min to be checked) 4 | -- 5 | def main.main(): 6 | let t0 = newchan ty, 0; 7 | let t1 = newchan ty, 0; 8 | let t2 = newchan ty, 0; 9 | spawn philo(t0,t1); 10 | spawn philo(t1,t2); 11 | spawn philo(t2,t0); 12 | spawn aFork(t0); 13 | spawn aFork(t1); 14 | spawn aFork(t2); 15 | 16 | def aFork(fork): 17 | send fork; 18 | recv fork; 19 | call aFork(fork); 20 | 21 | 22 | def philo(left,right) : 23 | select 24 | case recv left; 25 | select 26 | case recv right; 27 | -- EAT 28 | send right; 29 | send left; 30 | call philo(left,right); 31 | case tau; 32 | send left; 33 | call philo(left,right); 34 | endselect; 35 | case recv right; 36 | select 37 | case recv left; 38 | -- EAT 39 | send right; 40 | send left; 41 | call philo(left,right); 42 | case tau; 43 | send right; 44 | call philo(left,right); 45 | endselect; 46 | endselect; -------------------------------------------------------------------------------- /examples/fibonacci-async.cfgo: -------------------------------------------------------------------------------- 1 | -- This is the Fibonacci example with a buffered channel 2 | -- it is live and safe 3 | -- and should take about 20s to be checked 4 | -- 5 | def t0() : let a = newchan ty, 1 ; 6 | spawn fib(a); 7 | recv a; 8 | 9 | def fib(x): if 10 | send x; 11 | else let b = newchan ty, 1 ; 12 | spawn fib(b); 13 | spawn fib(b); 14 | recv b; recv b; send x; 15 | endif; 16 | 17 | -------------------------------------------------------------------------------- /examples/fibonacci.cfgo: -------------------------------------------------------------------------------- 1 | -- This is the Fibonacci example (Section 4.2.2) 2 | -- it is live and safe 3 | -- and should take about 10s to be checked 4 | -- 5 | def t0() : let a = newchan ty, 0 ; 6 | spawn fib(a); 7 | recv a; 8 | 9 | def fib(x): if 10 | send x; 11 | else let b = newchan ty, 0 ; 12 | spawn fib(b); 13 | spawn fib(b); 14 | recv b; recv b; send x; 15 | endif; 16 | 17 | -------------------------------------------------------------------------------- /examples/nofence.cgo: -------------------------------------------------------------------------------- 1 | -- This is an example of Go type that is NOT fenced (see Section 4.2.2) 2 | -- the tool rejects it as "not fenced" 3 | -- 4 | def t0() : let a = newchan ty, 0 ; 5 | spawn t1(a) 6 | 7 | def t1(x): recv x; 8 | let b = newchan ty, 0; 9 | spawn w(x); 10 | spawn r(x); 11 | spawn t1(x); -- or "call t1(x);" 12 | 13 | 14 | def w(x): send x; 15 | call r(x); 16 | 17 | def r(x): recv x; 18 | call r(x); -------------------------------------------------------------------------------- /examples/not-safe.cgo: -------------------------------------------------------------------------------- 1 | -- This example illustrates closing of channels this example is *not* 2 | -- safe because channel 'a' is closed twice 3 | -- it is however live. 4 | -- 5 | def t0() : let a = newchan ty, 0 ; 6 | spawn t1(a); 7 | send a; 8 | close a; 9 | 10 | def t1(x) : recv x; close x; 11 | -------------------------------------------------------------------------------- /examples/primesieve.cgo: -------------------------------------------------------------------------------- 1 | -- This is the prime sieve example (Section 1, page 2) 2 | -- it is live and safe 3 | -- and should take less than a second to be checked. 4 | -- 5 | def t0() : let a = newchan ty, 0 ; 6 | spawn g(a); 7 | spawn r(a); 8 | 9 | def r(x): recv x; 10 | let b = newchan ty, 0; 11 | spawn f(x,b); 12 | spawn r(b); 13 | 14 | def f(x,y): recv x; 15 | if 16 | send y; 17 | call f(x,y); 18 | else 19 | call f(x,y); 20 | endif; 21 | 22 | def g(x): send x; 23 | call g(x); -------------------------------------------------------------------------------- /gong.cabal: -------------------------------------------------------------------------------- 1 | name: Gong 2 | version: 0.1.1.0 3 | synopsis: Gong liveness and safety checker 4 | description: Gong liveness and safety checker for MiGo types. 5 | license: Apache-2.0 6 | license-file: LICENSE 7 | author: Julien Lange, Bernardo Toninho 8 | maintainer: nickng@imperial.ac.uk 9 | build-type: Simple 10 | extra-source-files: README.md 11 | cabal-version: >=1.10 12 | category: Testing 13 | source-repository head 14 | type: git 15 | location: git://github.com/nickng/gong.git 16 | 17 | 18 | executable Gong 19 | main-is: Gong.hs 20 | other-extensions: MultiParamTypeClasses, TemplateHaskell, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, UndecidableInstances, DeriveDataTypeable, BangPatterns, DeriveGeneric, DeriveAnyClass 21 | build-depends: base >=4.8, unbound >=0.4, transformers >=0.4, containers >=0.5 && <0.6, parsec >=3.1 && <3.2, pretty >=1.1 && <1.2, filepath >=1.4 && <1.5, process >=1.2, cmdargs >=0.10 && <0.11, ansi-terminal >=0.6 && <0.7, deepseq >=1.4 && <1.5, parallel >=3.2 && <3.3 22 | hs-source-dirs: . 23 | default-language: Haskell2010 24 | -------------------------------------------------------------------------------- /tests/abc.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn t1(a); 3 | send a; 4 | 5 | def t1(x): let b = newchan ty, 0; 6 | spawn t2(x,b); 7 | send b; 8 | call t1(b); 9 | 10 | def t2(x,y): recv x; send y; 11 | -------------------------------------------------------------------------------- /tests/async-basic.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 1 ; 2 | let b = newchan ty, 1 ; 3 | spawn t1(b); 4 | if 5 | send b; 6 | send a; 7 | else 8 | send a; 9 | send b; 10 | endif; 11 | def t1(x): recv x; recv x; 12 | 13 | -------------------------------------------------------------------------------- /tests/async-dual.cgo: -------------------------------------------------------------------------------- 1 | -- This example illustrates the use of asynchronous channels (bound > 0) 2 | -- 3 | def t0() : let a = newchan ty, 1 ; 4 | let b = newchan ty, 1 ; 5 | spawn t1(a,b); 6 | spawn t1(b,a); 7 | 8 | def t1(x,y): send x; recv y; 9 | 10 | -------------------------------------------------------------------------------- /tests/async-fib-1chan.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 1 ; 2 | spawn fib(a); 3 | recv a; 4 | 5 | def fib(x): if 6 | send x; 7 | else let b = newchan ty, 1 ; 8 | spawn fib(b); 9 | spawn fib(b); 10 | recv b; recv b; send x; 11 | endif; 12 | 13 | -------------------------------------------------------------------------------- /tests/async-fib.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn fib(a); 3 | recv a; 4 | 5 | def fib(x): if 6 | send x; 7 | else let b = newchan ty, 2 ; 8 | spawn fib(b); 9 | spawn fib(b); 10 | spawn wait(b,x); 11 | endif; 12 | 13 | 14 | def wait(x,y): recv x; recv x; send y; 15 | -------------------------------------------------------------------------------- /tests/async-finitestate-close.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 1 ; 2 | let b = newchan ty, 1; 3 | spawn w(a); 4 | spawn r(a,b); 5 | 6 | def r(x,y): let c = newchan ty, 1; -- test Name GC 7 | close c; 8 | recv x; 9 | call r(x,c); 10 | 11 | 12 | def w(x): send x; 13 | send x; 14 | call w(x); -------------------------------------------------------------------------------- /tests/async-finitestate-send.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 1 ; 2 | let b = newchan ty, 1; 3 | spawn w(a); 4 | spawn r(a,b); 5 | 6 | def r(x,y): let c = newchan ty, 1; -- test Name GC 7 | send c; 8 | recv x; 9 | call r(x,c); 10 | 11 | 12 | def w(x): send x; 13 | send x; 14 | call w(x); -------------------------------------------------------------------------------- /tests/async-finitestate.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 1 ; 2 | let b = newchan ty, 1; 3 | spawn w(a); 4 | spawn r(a,b); 5 | 6 | def r(x,y): let c = newchan ty, 1; -- test Name GC 7 | recv x; 8 | call r(x,c); 9 | 10 | 11 | def w(x): send x; 12 | send x; 13 | call w(x); -------------------------------------------------------------------------------- /tests/async-notlive.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 1 ; 2 | spawn t1(a); 3 | recv a; 4 | 5 | def t1(x): let b = newchan ty, 1 ; 6 | spawn t1(b); 7 | recv b; 8 | send x; 9 | 10 | -------------------------------------------------------------------------------- /tests/async-primesieve.cgo: -------------------------------------------------------------------------------- 1 | -- Takes about 10min 2 | -- 3 | def t0() : let a = newchan ty, 1 ; 4 | spawn g(a); 5 | spawn r(a); 6 | 7 | def r(x): recv x; 8 | let b = newchan ty, 1; 9 | spawn f(x,b); 10 | spawn r(b); 11 | 12 | def f(x,y): recv x; 13 | if 14 | send y; 15 | call f(x,y); 16 | else 17 | call f(x,y); 18 | endif; 19 | 20 | def g(x): send x; 21 | call g(x); -------------------------------------------------------------------------------- /tests/badphilo.cgo: -------------------------------------------------------------------------------- 1 | -- This one is deadlocked, obv (17s) 2 | def main.main(): 3 | let t0 = newchan ty, 0; 4 | let t1 = newchan ty, 0; 5 | let t2 = newchan ty, 0; 6 | spawn philo(t0,t1); 7 | spawn philo(t1,t2); 8 | spawn philo(t2,t0); 9 | spawn aFork(t0); 10 | spawn aFork(t1); 11 | spawn aFork(t2); 12 | 13 | def aFork(fork): 14 | send fork; 15 | recv fork; 16 | call aFork(fork); 17 | 18 | 19 | def philo(left,right) : 20 | recv left; 21 | recv right; 22 | -- EAT 23 | send left; 24 | send right; 25 | call philo(left,right); -------------------------------------------------------------------------------- /tests/badprime.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn g(a); 3 | spawn r(a); 4 | 5 | def r(x): recv x; 6 | let b = newchan ty, 0; 7 | spawn f(x,b); 8 | spawn r(b); 9 | 10 | def f(x,y): recv x; send y; 11 | recv x; send y; 12 | recv x; send y; 13 | recv x; send y; -- 2-live but not 3-live 14 | -- -- 15 | -- recv x; send y; 16 | -- recv x; send y; 17 | -- recv x; send y; 18 | -- recv x; send y; -- 4-live but not 5-live 19 | 20 | -- recv x; send y; 21 | -- recv x; send y; 22 | -- recv x; send y; 23 | -- recv x; send y; -- 5-live 24 | 25 | 26 | def g(x): send x; 27 | call g(x); -------------------------------------------------------------------------------- /tests/basic.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | let b = newchan ty, 0 ; 3 | spawn t1(b); 4 | if 5 | send b; 6 | send a; 7 | else 8 | send a; 9 | send b; 10 | endif; 11 | def t1(x): recv x; recv x; 12 | 13 | -------------------------------------------------------------------------------- /tests/blockingasync.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 2 ; 2 | let b = newchan ty, 2 ; 3 | spawn one(b,a); 4 | spawn two(a); 5 | spawn three(b); 6 | 7 | 8 | 9 | def one(x,y): recv x; recv x; send y; 10 | 11 | 12 | def two(x): recv x; 13 | 14 | def three(x): send x; send x; -------------------------------------------------------------------------------- /tests/closing.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | close a; 3 | if 4 | recv a; 5 | else 6 | tau; 7 | -- close a; 8 | endif; -------------------------------------------------------------------------------- /tests/fibonacci-1chan.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn fib(a); 3 | recv a; 4 | 5 | def fib(x): if 6 | send x; 7 | else let b = newchan ty, 0 ; 8 | spawn fib(b); 9 | spawn fib(b); 10 | recv b; recv b; send x; 11 | endif; 12 | 13 | -------------------------------------------------------------------------------- /tests/fibonacci.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn fib(a); 3 | recv a; 4 | 5 | def fib(x): if 6 | send x; 7 | else let b = newchan ty, 0 ; 8 | let c = newchan ty, 0 ; 9 | spawn fib(b); 10 | spawn fib(c); 11 | spawn wait(b,c,x); 12 | endif; 13 | 14 | 15 | def wait(x,y,z): recv x; recv y; send z; 16 | -------------------------------------------------------------------------------- /tests/finitestate.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | let b = newchan ty, 0; 3 | spawn w(a); 4 | spawn r(a,b); 5 | 6 | def r(x,y): let c = newchan ty, 0; -- test Name GC 7 | recv x; 8 | call r(x,c); 9 | 10 | 11 | def w(x): send x; 12 | send x; 13 | call w(x); -------------------------------------------------------------------------------- /tests/freenames.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | let c = newchan ty, 0 ; 3 | spawn t2(a); 4 | send a; 5 | recv a; 6 | 7 | def t2(x): recv x; send x; 8 | -------------------------------------------------------------------------------- /tests/goodphilo.cgo: -------------------------------------------------------------------------------- 1 | -- Should take about 8min (or 2min with parallelisation) 2 | def main.main(): 3 | let t0 = newchan ty, 0; 4 | let t1 = newchan ty, 0; 5 | let t2 = newchan ty, 0; 6 | spawn philo(t0,t1); 7 | spawn philo(t1,t2); 8 | spawn philo(t2,t0); 9 | spawn aFork(t0); 10 | spawn aFork(t1); 11 | spawn aFork(t2); 12 | 13 | def aFork(fork): 14 | send fork; 15 | recv fork; 16 | call aFork(fork); 17 | 18 | 19 | def philo(left,right) : 20 | select 21 | case recv left; 22 | select 23 | case recv right; 24 | -- EAT 25 | send right; 26 | send left; 27 | call philo(left,right); 28 | case tau; 29 | send left; 30 | call philo(left,right); 31 | endselect; 32 | case recv right; 33 | select 34 | case recv left; 35 | -- EAT 36 | send right; 37 | send left; 38 | call philo(left,right); 39 | case tau; 40 | send right; 41 | call philo(left,right); 42 | endselect; 43 | endselect; -------------------------------------------------------------------------------- /tests/hernan-test1.cgo: -------------------------------------------------------------------------------- 1 | def main.main(): 2 | let t1 = newchan main.main.t1_0_0, 0; 3 | let t3 = newchan main.main.t3_0_0, 0; 4 | spawn main.main$1(t1,t3); 5 | select 6 | case recv t1; 7 | case tau;recv t3; 8 | endselect; 9 | def main.main$1(t1,t3): 10 | send t3; 11 | -------------------------------------------------------------------------------- /tests/hernan-test2.cgo: -------------------------------------------------------------------------------- 1 | def main.main(): 2 | let t1 = newchan main.main.t1_0_0, 0; 3 | let t3 = newchan main.main.t3_0_0, 0; 4 | spawn main.main$1(t1,t3); 5 | select 6 | case recv t1; 7 | case tau;recv t3; 8 | endselect; 9 | def main.main$1(t1,t3): 10 | select 11 | case send t1; 12 | case tau;send t3; 13 | endselect; 14 | -------------------------------------------------------------------------------- /tests/home.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | let b = newchan ty, 0; 3 | let c = newchan ty, 0; 4 | spawn t1(a,b,c); 5 | recv a; 6 | recv a; 7 | recv b; 8 | 9 | def t1(x,y,z): let d = newchan ty, 0; 10 | spawn ts(x); 11 | spawn tr(y); 12 | spawn tr(z); 13 | call t1(y,z,d); 14 | 15 | def tr(x): recv x; 16 | 17 | def ts(x): send x; send x; -------------------------------------------------------------------------------- /tests/init.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn t1(a); 3 | let b = newchan ty, 0 ; 4 | let c = newchan ty, 0 ; 5 | send a; 6 | send b; 7 | send c; 8 | 9 | def t1(x): let b = newchan ty, 0; 10 | spawn t2(x,b); 11 | send c; 12 | call t1(b) 13 | 14 | def t2(x,y): recv x; send y; 15 | -------------------------------------------------------------------------------- /tests/mini.cgo: -------------------------------------------------------------------------------- 1 | -- NOT 2-LIVE (but 1-live) 2 | def t0() : let a = newchan ty, 0 ; 3 | let b = newchan ty, 0 ; 4 | spawn t1(b); 5 | recv b; 6 | recv a; 7 | 8 | 9 | def t1(x): send x; -------------------------------------------------------------------------------- /tests/nickseq.cgo: -------------------------------------------------------------------------------- 1 | def main.main(): 2 | let t0 = newchan main.main.t0_0_0, 10; 3 | spawn main.worker(t0); 4 | spawn main.worker(t0); 5 | call main.main#3(t0); 6 | def main.main#3(t0): 7 | if send t0; call main.main#3(t0); else close t0; endif; 8 | def main.worker(jobQueue): 9 | call main.worker#1(jobQueue); 10 | def main.worker#1(jobQueue): 11 | select 12 | case recv jobQueue; 13 | call main.worker#1(jobQueue); 14 | case tau; 15 | endselect -------------------------------------------------------------------------------- /tests/norec.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn t1(a); 3 | send a; 4 | 5 | def t1(x): let b = newchan ty, 0; 6 | spawn t2(a,b); 7 | let c = newchan ty, 0; 8 | spawn t2(b,c); 9 | 10 | def t2(x,y): recv x; send y; 11 | -------------------------------------------------------------------------------- /tests/notfenced.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn t1(a); 3 | 4 | def t1(x): spawn w(x); 5 | spawn r(x); 6 | spawn t1(x); 7 | 8 | def w(x): send x; call w(x); 9 | 10 | def r(x): recv x; call r(x); 11 | 12 | -------------------------------------------------------------------------------- /tests/notlive.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn t1(a); 3 | recv a; 4 | 5 | def t1(x): let b = newchan ty, 0 ; 6 | spawn t1(b); 7 | recv b; 8 | send x; 9 | 10 | -------------------------------------------------------------------------------- /tests/primesieve-double.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn g(a); 3 | spawn r(a); 4 | 5 | def r(x): recv x; 6 | let b = newchan ty, 0; 7 | spawn f(x,b); 8 | spawn f(x,b); 9 | spawn r(b); 10 | 11 | 12 | def f(x,y): recv x; 13 | if 14 | send y; 15 | call f(x,y); 16 | else 17 | call f(x,y); 18 | endif; 19 | 20 | def g(x): send x; 21 | call g(x); -------------------------------------------------------------------------------- /tests/primesieve-nochoice.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn g(a); 3 | spawn r(a); 4 | 5 | def r(x): recv x; 6 | let b = newchan ty, 0; 7 | spawn f(x,b); 8 | spawn r(b); 9 | 10 | def f(x,y): recv x; 11 | send y; 12 | call f(x,y); 13 | 14 | 15 | def g(x): send x; 16 | call g(x); -------------------------------------------------------------------------------- /tests/primesieve.cgo: -------------------------------------------------------------------------------- 1 | -- This is the prime sieve example (Section 1, page 2) 2 | -- it is live and safe 3 | -- and should take 4 | def t0() : let a = newchan ty, 0 ; 5 | spawn g(a); 6 | spawn r(a); 7 | 8 | def r(x): recv x; 9 | let b = newchan ty, 0; 10 | spawn f(x,b); 11 | spawn r(b); 12 | 13 | def f(x,y): recv x; 14 | if 15 | send y; 16 | call f(x,y); 17 | else 18 | call f(x,y); 19 | endif; 20 | 21 | def g(x): send x; 22 | call g(x); -------------------------------------------------------------------------------- /tests/recvclosed.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | 3 | spawn r(a); 4 | close a; 5 | 6 | def r(x): recv x; 7 | call r(x); 8 | 9 | -------------------------------------------------------------------------------- /tests/safety.cgo: -------------------------------------------------------------------------------- 1 | -- This example illustrates closing of channels 2 | -- 3 | def t0() : let a = newchan ty, 0 ; 4 | spawn t1(a); 5 | send a; 6 | close a; 7 | 8 | def t1(x) : recv x; close x; 9 | -------------------------------------------------------------------------------- /tests/sameparam.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | let b = newchan ty, 0 ; 3 | spawn t1(b,b); 4 | send a; 5 | 6 | 7 | def t1(x,y): recv x; recv x; 8 | 9 | -------------------------------------------------------------------------------- /tests/select1.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | let b = newchan ty, 0 ; 3 | spawn t1(a,b); 4 | select 5 | case send a; recv b; 6 | case send b; recv a; 7 | endselect; 8 | 9 | 10 | def t1(x,y): recv x; recv x; 11 | 12 | -------------------------------------------------------------------------------- /tests/synasync.cgo: -------------------------------------------------------------------------------- 1 | -- Example in Secition 6 2 | -- 3 | def t0() : -- SYNC 4 | let a0 = newchan ty, 0; 5 | let b0 = newchan ty, 0; 6 | spawn pr(a0,b0); 7 | spawn pl(a0,b0); 8 | -- ASYNC 9 | let a1 = newchan ty, 1; 10 | let b1 = newchan ty, 1; 11 | spawn pl(a1,b1); 12 | spawn pl(b1,a1); 13 | 14 | 15 | 16 | 17 | def pl(x,y) : send x; recv y; 18 | 19 | def pr(x,y) : recv x; send y; -------------------------------------------------------------------------------- /tests/tau.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | let b = newchan ty, 0 ; 3 | spawn t1(a); 4 | spawn t2(a); 5 | spawn t1(b); 6 | spawn t2(b); 7 | 8 | def t1(x): tau; send x; tau; send x; tau 9 | 10 | def t2(x): tau; recv x; tau; recv x; 11 | -------------------------------------------------------------------------------- /tests/twophilo.cgo: -------------------------------------------------------------------------------- 1 | -- Should take about 2s 2 | def main.main(): 3 | let t0 = newchan ty, 0; 4 | let t1 = newchan ty, 0; 5 | spawn philo(t0,t1); 6 | spawn philo(t1,t0); 7 | spawn aFork(t0); 8 | spawn aFork(t1); 9 | 10 | def aFork(fork): 11 | send fork; 12 | recv fork; 13 | call aFork(fork); 14 | 15 | 16 | def philo(left,right) : 17 | select 18 | case recv left; 19 | select 20 | case recv right; 21 | -- EAT 22 | send right; 23 | send left; 24 | call philo(left,right); 25 | case tau; 26 | send left; 27 | call philo(left,right); 28 | endselect; 29 | case recv right; 30 | select 31 | case recv left; 32 | -- EAT 33 | send right; 34 | send left; 35 | call philo(left,right); 36 | case tau; 37 | send right; 38 | call philo(left,right); 39 | endselect; 40 | endselect; -------------------------------------------------------------------------------- /tests/vbasic.cgo: -------------------------------------------------------------------------------- 1 | def t0() : let a = newchan ty, 0 ; 2 | spawn t1(a); 3 | send a; 4 | recv a; 5 | send a; 6 | recv a; 7 | 8 | def t1(x): recv x; 9 | send x; 10 | recv x; 11 | send x; 12 | --------------------------------------------------------------------------------