├── Setup.hs
├── min.imp
├── .gitignore
├── gcd.imp
├── shell.nix
├── imp.cabal
├── LICENSE
├── README.md
└── src
    ├── Parse.hs
    ├── Run.hs
    ├── Imp.hs
    └── ImpToZ3.hs


/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/min.imp:
--------------------------------------------------------------------------------
1 | a := 10;
2 | a := a + 12;
3 | 
4 | if true { a := 11 } else { a := 12 }
5 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | # Emacs files
 2 | *~
 3 | \#*#
 4 | 
 5 | # Haskell and Cabal
 6 | .cabal-sandbox
 7 | cabal.sandbox.config
 8 | dist
 9 | ## Files generated by profiling
10 | *.hp
11 | *.prof
12 | 


--------------------------------------------------------------------------------
/gcd.imp:
--------------------------------------------------------------------------------
 1 | a := 1259574165;
 2 | b := 1328764095;
 3 | d := 0;
 4 | 
 5 | while (a / 2 * 2 == a) && (b / 2 * 2 == b) {
 6 |   a := a / 2;
 7 |   b := b / 2;
 8 |   d := d + 1
 9 | };
10 | 
11 | while !(a == b) {
12 |   if a / 2 * 2 == a {
13 |     a := a / 2
14 |   } else {
15 |     if b / 2 * 2 == b {
16 |       b := b / 2
17 |     } else {
18 |       if b <= (a - 1) {
19 |         a := (a - b) / 2
20 |       } else {
21 |         b := (b - a) / 2
22 |       }
23 |     }
24 |   }
25 | }
26 | 


--------------------------------------------------------------------------------
/shell.nix:
--------------------------------------------------------------------------------
 1 | { nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:
 2 | 
 3 | let
 4 | 
 5 |   inherit (nixpkgs) pkgs;
 6 | 
 7 |   f = { mkDerivation, base, stdenv, z3, containers, parsec }:
 8 |       mkDerivation {
 9 |         pname = "imp";
10 |         version = "0.1.0.0";
11 |         src = ./.;
12 |         libraryHaskellDepends = [ base z3 containers parsec ];
13 |         description = "Stuff for playing around with IMP programs";
14 |         license = stdenv.lib.licenses.bsd3;
15 |       };
16 | 
17 |   haskellPackages = if compiler == "default"
18 |                        then pkgs.haskellPackages
19 |                        else pkgs.haskell.packages.${compiler};
20 | 
21 |   drv = haskellPackages.callPackage f {};
22 | 
23 | in
24 | 
25 |   if pkgs.lib.inNixShell then drv.env else drv
26 | 


--------------------------------------------------------------------------------
/imp.cabal:
--------------------------------------------------------------------------------
 1 | -- Initial imp.cabal generated by cabal init.  For further documentation, 
 2 | -- see http://haskell.org/cabal/users-guide/
 3 | 
 4 | name:                imp
 5 | version:             0.1.0.0
 6 | synopsis:            Stuff for playing around with IMP programs.
 7 | -- description:         
 8 | license:             BSD3
 9 | license-file:        LICENSE
10 | author:              Tikhon Jelvis <tikhon@jelv.is>
11 | maintainer:          Tikhon Jelvis <tikhon@jelv.is>
12 | -- copyright:           
13 | category:            Language
14 | build-type:          Simple
15 | extra-source-files:  README.md
16 | cabal-version:       >=1.10
17 | 
18 | library
19 |   exposed-modules:     Imp
20 |   -- other-modules:       
21 |   -- other-extensions:    
22 |   build-depends:       base
23 |                      , containers
24 |                      , parsec
25 |                      , z3
26 |   hs-source-dirs:      src
27 |   default-language:    Haskell2010


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2015, Tikhon Jelvis <tikhon@jelv.is>
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions are met:
 7 | 
 8 |     * Redistributions of source code must retain the above copyright
 9 |       notice, this list of conditions and the following disclaimer.
10 | 
11 |     * Redistributions in binary form must reproduce the above
12 |       copyright notice, this list of conditions and the following
13 |       disclaimer in the documentation and/or other materials provided
14 |       with the distribution.
15 | 
16 |     * Neither the name of Tikhon Jelvis <tikhon@jelv.is> nor the names of other
17 |       contributors may be used to endorse or promote products derived
18 |       from this software without specific prior written permission.
19 | 
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # Analyzing IMP Programs
 2 | 
 3 | Some code for analyzing IMP programs with Z3, originally written for my [Compose 2016 talk](http://jelv.is/talks/compose-2016).
 4 | 
 5 | IMP is a *tiny* imperative language usually used to teach about formal semantics. Its operational semantics are particularly simple, which also makes it a great candidate to compile to Z3.
 6 | 
 7 | The code here is broken up into a few modules:
 8 |   * `Imp` contains the language's type definitions and an interpreter
 9 |   * `Parse` contains a *very simple* parser for IMP programs. It's extremely finicky: you have to have a semicolon after *every* command *except* for the last one, which *can't* have a semicolon.
10 |     * Look to the example program `gcd.imp` to see how the syntax works.
11 |   * `ImpToZ3` has a compiler that takes an IMP AST and shoves it into Z3. It includes helpers to run code *forwards* (ie use Z3 as an interpreter) and *backwards* (ie constrain the outputs and solve for inputs). It's fast backwards unless the output is invalid, in which case it hangs for a while depending on how far you unrolled the loops.
12 |   * `Run` has some quick utility functions for playing with IMP: a REPL, a function to run a file through the interpreter and some utilities for compiling and running a Z3 formula from a file.
13 |   
14 | For now, the code is pretty rough, and a bunch of things (like how far to unroll loops) are just constants. To unroll loops a different amount, you have to change `bound` in `ImpToZ3`! Think of them as handy but hacky scripts rather than a full program.
15 | 
16 | If you have problems building this, please tell me. I've been using Nix for it (hence the `.nix` file), so I haven't set any bounds in my `.cabal` file. That'll probably cause problems down the line…
17 | 
18 | 


--------------------------------------------------------------------------------
/src/Parse.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE RecordWildCards #-}
 2 | module Parse where
 3 | 
 4 | import           Text.Parsec
 5 | import           Text.Parsec.Char
 6 | import           Text.Parsec.Expr
 7 | import           Text.Parsec.Language (javaStyle)
 8 | import           Text.Parsec.String
 9 | import qualified Text.Parsec.Token    as Token
10 | 
11 | import           Imp                  (AExp (..), BExp (..), Cmd (..), Name (..))
12 | 
13 | -- pretending Haskell has a good module system…
14 | Token.TokenParser {..} = Token.makeTokenParser javaStyle
15 | 
16 | binary name fun = Infix (fun <$ reservedOp name) AssocLeft
17 | 
18 | name = Name <$> identifier
19 | 
20 | aexp :: Parser AExp
21 | aexp = buildExpressionParser table term
22 |  where term =  Lit . fromIntegral <$> integer
23 |            <|> Var <$> name
24 |            <|> parens aexp
25 |        table = [ [ binary "+" (:+:), binary "-" (:-:) ]
26 |                , [ binary "*" (:*:), binary "/" (:/:) ]
27 |                ]
28 | 
29 | bexp :: Parser BExp
30 | bexp = buildExpressionParser table term
31 |   where term =  True' <$ reserved "true"
32 |             <|> False' <$ reserved "false"
33 |             <|> try ((:<=:) <$> (aexp <* reservedOp "<=") <*> aexp)
34 |             <|> try ((:==:) <$> (aexp <* reservedOp "==") <*> aexp)
35 |             <|> try (parens bexp)
36 |         table = [ [ Prefix (Not <$ reservedOp "!") ]
37 |                 , [ binary "&&" (:&:), binary "||" (:|:) ]
38 |                 ]
39 | 
40 | cmd :: Parser Cmd
41 | cmd = foldl Seq Skip <$> (statement `sepBy1` symbol ";")
42 |   where statement =  If <$> (reserved "if" *> bexp)
43 |                         <*> braces cmd
44 |                         <*> (reserved "else" *> braces cmd)
45 |                  <|> While <$> (reserved "while" *> bexp)
46 |                            <*> braces cmd
47 |                  <|> Set <$> (name <* reservedOp ":=") <*> aexp
48 | 
49 | parseCmd file = parse (cmd <* eof) file
50 | 


--------------------------------------------------------------------------------
/src/Run.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE LambdaCase        #-}
 2 | {-# LANGUAGE OverloadedStrings #-}
 3 | module Run where
 4 | 
 5 | import           Control.Monad ((<=<))
 6 | 
 7 | import           Data.Map      (Map)
 8 | import qualified Data.Map      as Map
 9 | 
10 | import qualified Z3.Monad      as Z3
11 | 
12 | import           Imp
13 | import qualified ImpToZ3       as Z3
14 | import           Parse
15 | 
16 | run :: String -> IO ()
17 | run input = case parseCmd "<interactive>" input of
18 |   Left err  -> print err
19 |   Right cmd -> print $ evalCmd [] cmd
20 | 
21 | runFile :: FilePath -> IO ()
22 | runFile path = do
23 |   program <- readFile path
24 |   case parseCmd path program of
25 |     Left err  -> print err
26 |     Right cmd -> case evalCmd [] cmd of
27 |       Nothing  -> putStrLn "Scope error?"
28 |       Just res -> print res
29 | 
30 | z3File exec scope path = do
31 |   program <- readFile path
32 |   case parseCmd path program of
33 |     Left err  -> print err
34 |     Right cmd -> putStrLn <=< runZ3 $ do
35 |       exec scope cmd
36 |       Z3.solverCheckAndGetModel >>= \case
37 |         (Z3.Sat, Just model) -> Z3.modelToString model
38 |         (result, _)          -> return $ "Failed: " ++ show result
39 |   where runZ3 = Z3.evalZ3With (Just Z3.QF_BV) Z3.opts
40 | 
41 | gcdPath = "/home/tikhon/Documents/programming/haskell/imp/gcd.imp"
42 | 
43 | forwardsExample = z3File Z3.forwards (Map.fromList []) gcdPath
44 | 
45 | backwardsExample = z3File Z3.backwards constraints gcdPath
46 |   where constraints = (Map.fromList [("a", 135), ("b", 135), ("d", 0)])
47 | 
48 | repl :: IO ()
49 | repl = go []
50 |   where go scope = do putStr "> "
51 |                       x <- getLine
52 |                       case parseCmd "<interactive>" x of
53 |                         Left err  -> do print err; go scope
54 |                         Right cmd -> case evalCmd scope cmd of
55 |                           Just scope' -> do print scope'; go scope'
56 |                           Nothing     -> do putStrLn "Error!"; go scope
57 | 


--------------------------------------------------------------------------------
/src/Imp.hs:
--------------------------------------------------------------------------------
 1 | module Imp where
 2 | 
 3 | import           Data.Int    (Int32)
 4 | import           Data.String (IsString (..))
 5 | 
 6 | -- | The int parameter makes it easy to create new versions of a
 7 | -- variable.
 8 | newtype Name = Name String deriving (Eq, Ord)
 9 | 
10 | instance Show Name where show (Name s) = s
11 | 
12 | instance IsString Name where fromString = Name
13 | 
14 | type Scope = [(Name, Int32)]
15 | 
16 | data AExp = Lit Int32
17 |           | Var Name
18 |           | AExp :+: AExp
19 |           | AExp :-: AExp
20 |           | AExp :*: AExp
21 |           | AExp :/: AExp deriving (Show, Eq)
22 | 
23 | data BExp = True'
24 |           | False'
25 |           | AExp :<=: AExp
26 |           | AExp :==: AExp
27 |           | BExp :|: BExp
28 |           | BExp :&: BExp
29 |           | Not BExp deriving (Show, Eq)
30 | 
31 | data Cmd = Skip
32 |          | Set Name AExp
33 |          | Seq Cmd Cmd
34 |          | If BExp Cmd Cmd
35 |          | While BExp Cmd deriving (Show, Eq)
36 | 
37 | evalAExp :: Scope -> AExp -> Maybe Int32
38 | evalAExp _ (Lit i)        = Just i
39 | evalAExp scope (Var name) = lookup name scope
40 | evalAExp scope (e_1 :+: e_2) =
41 |   (+) <$> evalAExp scope e_1 <*> evalAExp scope e_2
42 | evalAExp scope (e_1 :-: e_2) =
43 |   (-) <$> evalAExp scope e_1 <*> evalAExp scope e_2
44 | evalAExp scope (e_1 :*: e_2) =
45 |   (*) <$> evalAExp scope e_1 <*> evalAExp scope e_2
46 | evalAExp scope (e_1 :/: e_2) =
47 |   div <$> evalAExp scope e_1 <*> evalAExp scope e_2
48 | 
49 | evalBExp :: Scope -> BExp -> Maybe Bool
50 | evalBExp scope True'  = Just True
51 | evalBExp scope False' = Just False
52 | evalBExp scope (e_1 :<=: e_2) =
53 |   (<=) <$> evalAExp scope e_1 <*> evalAExp scope e_2
54 | evalBExp scope (e_1 :==: e_2) =
55 |   (==) <$> evalAExp scope e_1 <*> evalAExp scope e_2
56 | evalBExp scope (e_1 :|: e_2) =
57 |   (||) <$> evalBExp scope e_1 <*> evalBExp scope e_2
58 | evalBExp scope (e_1 :&: e_2) =
59 |   (&&) <$> evalBExp scope e_1 <*> evalBExp scope e_2
60 | evalBExp scope (Not e) = not <$> evalBExp scope e
61 | 
62 | evalCmd :: Scope -> Cmd -> Maybe Scope
63 | evalCmd scope Skip = Just scope
64 | evalCmd scope (Set name val) = set <$> evalAExp scope val
65 |   where set int = (name, int) : filter (\ (var, _) -> var /= name) scope
66 | evalCmd scope (Seq c_1 c_2) =
67 |   do scope' <- evalCmd scope c_1
68 |      evalCmd scope' c_2
69 | evalCmd scope (If cond c_1 c_2) =
70 |   do res <- evalBExp scope cond
71 |      if res then evalCmd scope c_1
72 |             else evalCmd scope c_2
73 | evalCmd scope loop@(While cond body) =
74 |   do res <- evalBExp scope cond
75 |      if res then evalCmd scope (Seq body loop)
76 |             else return scope
77 | 


--------------------------------------------------------------------------------
/src/ImpToZ3.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE LambdaCase     #-}
  2 | {-# LANGUAGE NamedFieldPuns #-}
  3 | module ImpToZ3 where
  4 | 
  5 | import           Control.Monad (foldM, forM_, (=<<))
  6 | 
  7 | import           Data.Map      (Map, (!))
  8 | import qualified Data.Map      as Map
  9 | import           Data.Maybe    (fromJust)
 10 | 
 11 | import           Z3.Monad      (AST, Z3, (+?))
 12 | import qualified Z3.Monad      as Z3
 13 | 
 14 | import           Imp
 15 | 
 16 | type Z3Var = AST
 17 | 
 18 | type Vars = Map Name Z3Var
 19 | 
 20 | getZ3Var :: Name -> Vars -> Z3Var
 21 | getZ3Var name scope = case Map.lookup name scope of
 22 |   Just x  -> x
 23 |   Nothing -> error $ "Variable " ++ show name ++ " does not exist!"
 24 | 
 25 | makeVar :: Name -> Z3 AST
 26 | makeVar name = Z3.mkFreshBvVar (show name) width
 27 | 
 28 | makeVars :: [Name] -> Z3 Vars
 29 | makeVars names = foldM addVar Map.empty names
 30 |   where addVar vars name = do var <- makeVar name
 31 |                               return (Map.insert name var vars)
 32 | 
 33 | width :: Int
 34 | width = 32
 35 | 
 36 | bound :: Int
 37 | bound = 30
 38 | 
 39 | unroll :: Int -> Cmd -> Cmd
 40 | unroll bound = \case
 41 |   While cond body -> unrollLoop bound (While cond body)
 42 |   c_1 `Seq` c_2   -> unroll bound c_1 `Seq` unroll bound c_2
 43 |   If cond c_1 c_2 -> If cond (unroll bound c_1) (unroll bound c_2)
 44 |   cmd             -> cmd
 45 |   where unrollLoop 0 _                      = Skip
 46 |         unrollLoop n loop@(While cond body) =
 47 |           If cond (body `Seq` unrollLoop (n - 1) loop) Skip
 48 | 
 49 | 
 50 | op :: (AST -> AST -> Z3 AST) -> Z3 AST -> Z3 AST -> Z3 AST
 51 | op f a b = do a' <- a; b' <- b; f a' b'
 52 | 
 53 | aexp :: Vars -> AExp -> Z3 AST
 54 | aexp scope = \case
 55 |   Lit n       -> Z3.mkBvNum width n
 56 |   Var name    -> return . fromJust $ Map.lookup name scope
 57 |   e_1 :+: e_2 -> op Z3.mkBvadd (aexp scope e_1) (aexp scope e_2)
 58 |   e_1 :-: e_2 -> op Z3.mkBvsub (aexp scope e_1) (aexp scope e_2)
 59 |   e_1 :*: e_2 -> op Z3.mkBvmul (aexp scope e_1) (aexp scope e_2)
 60 |   e_1 :/: e_2 -> op Z3.mkBvsdiv (aexp scope e_1) (aexp scope e_2)
 61 | 
 62 | 
 63 | bexp :: Vars -> BExp -> Z3 AST
 64 | bexp scope = \case
 65 |   True'        -> Z3.mkBool True
 66 |   False'       -> Z3.mkBool False
 67 |   e_1 :<=: e_2 -> op Z3.mkBvsle (aexp scope e_1) (aexp scope e_2)
 68 |   e_1 :==: e_2 -> op Z3.mkEq (aexp scope e_1) (aexp scope e_2)
 69 |   b_1 :|: b_2  -> do b_1 <- bexp scope b_1
 70 |                      b_2 <- bexp scope b_2
 71 |                      Z3.mkOr [b_1, b_2]
 72 |   b_1 :&: b_2  -> do b_1 <- bexp scope b_1
 73 |                      b_2 <- bexp scope b_2
 74 |                      Z3.mkAnd [b_1, b_2]
 75 |   Not b        -> Z3.mkNot =<< bexp scope b
 76 | 
 77 | cmd :: Vars -> Cmd -> Z3 Vars
 78 | cmd inputs = compile inputs . unroll bound
 79 |   where compile scope = \case
 80 |           Skip            -> return scope
 81 |           Set name val    -> do newVal <- aexp scope val
 82 |                                 newVar <- makeVar name
 83 |                                 Z3.assert =<< Z3.mkEq newVar newVal
 84 |                                 return $ Map.insert name newVar scope
 85 |           Seq c_1 c_2     -> do scope'  <- compile scope c_1
 86 |                                 compile scope' c_2
 87 |           If cond c_1 c_2 -> do cond'   <- bexp scope cond
 88 |                                 scope'  <- compile scope c_1
 89 |                                 scope'' <- compile scope c_2
 90 |                                 makePhis cond' scope scope' scope''
 91 |           _               -> error "Loops have to be unrolled before compiling to SMT!"
 92 | 
 93 | constrainVars :: Map Name Int -> Vars -> Z3 ()
 94 | constrainVars values scope = forM_ (Map.keys values) $ \ name -> do
 95 |   val <- Z3.mkBvNum width (values ! name)
 96 |   Z3.assert =<< Z3.mkEq (scope ! name) val
 97 | 
 98 | forwards :: Map Name Int -> Cmd -> Z3 ()
 99 | forwards values program = do initialScope <- makeVars $ Map.keys values
100 |                              constrainVars values initialScope
101 |                              cmd initialScope program
102 |                              return ()
103 | 
104 | backwards :: Map Name Int -> Cmd -> Z3 ()
105 | backwards values program = do initialScope <- makeVars $ Map.keys values
106 |                               finalScope   <- cmd initialScope program
107 |                               constrainVars values finalScope
108 |                               return ()
109 | 
110 | opts = Z3.opt "MODEL" True
111 | 
112 | -- | Encodes the result of a conditional by asserting new values for
113 | -- each variable depending on which branch was taken. Example:
114 | --
115 | --  y := 10;
116 | --  if cond { x := 1; y := y + 10 }
117 | --     else { y := y + 11; z := y }
118 | --
119 | --  x_1 = 1
120 | --  y_2 = y_1 + 10
121 | --  y_3 = y_ 1 + 11
122 | --  z_1 = y_3
123 | --  x_2 = ite(cond, x_1, x_0)
124 | --  y_4 = ite(cond, y_2, y_3)
125 | --  z_2 = ite(cond, z_0, z_1)
126 | makePhis :: AST -> Vars -> Vars -> Vars -> Z3 Vars
127 | makePhis cond original scope' scope'' = foldM go original $ Map.keys original
128 |   where go scope name = do
129 |           newVar     <- makeVar name
130 |           ite        <- Z3.mkIte cond (getZ3Var name scope') (getZ3Var name scope'')
131 |           constraint <- Z3.mkEq newVar ite
132 |           Z3.assert constraint
133 |           return $ Map.insert name newVar scope
134 | 


--------------------------------------------------------------------------------