macaw-x86-syntax: Syntactic sugar for macaw-x86-symbolic CFGs

macaw-x86-syntax/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2024 Galois Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+  * Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+  * Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution.
+
+  * Neither the name of Galois, Inc. nor the names of its contributors
+    may be used to endorse or promote products derived from this
+    software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

macaw-x86-syntax/README.md

@@ -0,0 +1,36 @@
+# macaw-x86-syntax
+
+This package provides concrete syntax for macaw-x86-symbolic types and
+operations.
+
+Concretely, it implements a `ParserHooks` for use with [`crucible-syntax`][syn].
+This `ParserHooks` supports the following types and operations:
+
+**Types**:
+
+- `X86Regs`: the struct of all x86_64 registers
+
+**Operations**:
+
+- `get-reg :: X86Reg -> X86Regs -> t`: extract an x86 register
+- `set-reg :: X86Reg -> t -> X86Regs -> X86Regs`: set an x86 register
+- Registers:
+  - `rip :: X86Reg`: instruction pointer
+  - `rax :: X86Reg`: SysV return value register
+  - `rbx :: X86Reg`: general-purpose register
+  - `rcx :: X86Reg`: general-purpose register
+  - `rdx :: X86Reg`: general-purpose register
+  - `rsp :: X86Reg`: stack pointer
+  - `rbp :: X86Reg`: base pointer
+  - `rsi :: X86Reg`: general-purpose register
+  - `rdi :: X86Reg`: general-purpose register
+  - `r8 :: X86Reg`: general-purpose register
+  - `r9 :: X86Reg`: general-purpose register
+  - `r10 :: X86Reg`: general-purpose register
+  - `r11 :: X86Reg`: general-purpose register
+  - `r12 :: X86Reg`: general-purpose register
+  - `r13 :: X86Reg`: general-purpose register
+  - `r14 :: X86Reg`: general-purpose register
+  - `r15 :: X86Reg`: general-purpose register
+
+[syn]: https://github.com/GaloisInc/crucible/tree/master/crucible-syntax

macaw-x86-syntax/macaw-x86-syntax.cabal

@@ -0,0 +1,133 @@
+Cabal-version: 2.2
+Name:          macaw-x86-syntax
+Version:       0.1
+Author:        Galois Inc.
+Maintainer:    [email protected]
+Build-type:    Simple
+License:       BSD-3-Clause
+License-file:  LICENSE
+Category:      Language
+Synopsis:      A syntax for macaw-x86-symbolic control-flow graphs
+-- Description:
+
+extra-doc-files: README.md
+extra-source-files:
+  test-data/*.cbl
+  test-data/*.out.good
+
+common shared
+  -- Specifying -Wall and -Werror can cause the project to fail to build on
+  -- newer versions of GHC simply due to new warnings being added to -Wall. To
+  -- prevent this from happening we manually list which warnings should be
+  -- considered errors. We also list some warnings that are not in -Wall, though
+  -- try to avoid "opinionated" warnings (though this judgement is clearly
+  -- subjective).
+  --
+  -- Warnings are grouped by the GHC version that introduced them, and then
+  -- alphabetically.
+  --
+  -- A list of warnings and the GHC version in which they were introduced is
+  -- available here:
+  -- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/using-warnings.html
+
+  -- Since GHC 8.10 or earlier:
+  ghc-options:
+    -Wall
+    -Werror=compat-unqualified-imports
+    -Werror=deferred-type-errors
+    -Werror=deprecated-flags
+    -Werror=deprecations
+    -Werror=deriving-defaults
+    -Werror=dodgy-foreign-imports
+    -Werror=duplicate-exports
+    -Werror=empty-enumerations
+    -Werror=identities
+    -Werror=inaccessible-code
+    -Werror=incomplete-patterns
+    -Werror=incomplete-record-updates
+    -Werror=incomplete-uni-patterns
+    -Werror=inline-rule-shadowing
+    -Werror=missed-extra-shared-lib
+    -Werror=missing-exported-signatures
+    -Werror=missing-fields
+    -Werror=missing-home-modules
+    -Werror=missing-methods
+    -Werror=overflowed-literals
+    -Werror=overlapping-patterns
+    -Werror=partial-fields
+    -Werror=partial-type-signatures
+    -Werror=simplifiable-class-constraints
+    -Werror=star-binder
+    -Werror=star-is-type
+    -Werror=tabs
+    -Werror=typed-holes
+    -Werror=unrecognised-pragmas
+    -Werror=unrecognised-warning-flags
+    -Werror=unsupported-calling-conventions
+    -Werror=unsupported-llvm-version
+    -Werror=unticked-promoted-constructors
+    -Werror=unused-imports
+    -Werror=warnings-deprecations
+    -Werror=wrong-do-bind
+
+  if impl(ghc >= 9.2)
+    ghc-options:
+      -Werror=ambiguous-fields
+      -Werror=operator-whitespace
+      -Werror=operator-whitespace-ext-conflict
+      -Werror=redundant-bang-patterns
+
+  if impl(ghc >= 9.4)
+    ghc-options:
+      -Werror=forall-identifier
+      -Werror=misplaced-pragmas
+      -Werror=redundant-strictness-flags
+      -Werror=type-equality-out-of-scope
+      -Werror=type-equality-requires-operators
+
+  ghc-prof-options: -O2 -fprof-auto-top
+  default-language: Haskell2010
+
+library
+  import: shared
+
+  build-depends:
+    base >= 4.13,
+    containers,
+    crucible,
+    crucible-syntax,
+    macaw-base,
+    macaw-symbolic,
+    macaw-x86,
+    macaw-x86-symbolic,
+    mtl,
+    parameterized-utils,
+    text,
+    what4,
+
+  hs-source-dirs: src
+
+  exposed-modules:
+    Data.Macaw.X86.Symbolic.Syntax
+
+test-suite macaw-x86-syntax-tests
+  import: shared
+  type: exitcode-stdio-1.0
+  main-is: Test.hs
+  hs-source-dirs: test
+  build-depends:
+    base,
+    containers,
+    crucible >= 0.1,
+    crucible-syntax,
+    crucible-llvm-syntax,
+    filepath,
+    macaw-symbolic,
+    macaw-symbolic-syntax,
+    macaw-x86,
+    macaw-x86-symbolic,
+    macaw-x86-syntax,
+    parameterized-utils >= 0.1.7,
+    tasty,
+    tasty-golden,
+    text,

macaw-x86-syntax/src/Data/Macaw/X86/Symbolic/Syntax.hs

@@ -0,0 +1,140 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | 'LCSC.ParserHooks' for parsing macaw-x86-symbolic CFGs.
+module Data.Macaw.X86.Symbolic.Syntax
+  ( x86ParserHooks
+    -- * Types
+  , x86TypeParser
+    -- * Operations
+  , parseRegs
+  , parseReg
+  , x86AtomParser
+  ) where
+
+import Control.Applicative ( empty )
+import Control.Monad qualified as Monad
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.State.Strict (MonadState)
+import Control.Monad.Writer.Strict (MonadWriter)
+import Data.Text qualified as Text
+
+import Data.Macaw.Symbolic qualified as DMS
+import Data.Macaw.X86 qualified as X86
+import Data.Macaw.X86.Symbolic qualified as X86
+import Data.Parameterized.Context qualified as Ctx
+import Data.Parameterized.Some (Some(..))
+import Lang.Crucible.CFG.Expr as Expr
+import Lang.Crucible.CFG.Reg (Atom, Stmt)
+import Lang.Crucible.CFG.Reg qualified as Reg
+import Lang.Crucible.Syntax.Atoms qualified as LCSA
+import Lang.Crucible.Syntax.Concrete qualified as LCSC
+import Lang.Crucible.Syntax.Monad qualified as LCSM
+import Lang.Crucible.Types qualified as LCT
+import What4.ProgramLoc (Posd(..))
+
+-- | Parser hooks for macaw-x86-symbolic CFGs
+x86ParserHooks :: LCSC.ParserHooks ext
+x86ParserHooks =
+  LCSC.ParserHooks
+  { LCSC.extensionTypeParser = x86TypeParser
+  , LCSC.extensionParser = x86AtomParser
+  }
+
+---------------------------------------------------------------------
+-- Types
+
+-- Helper, not exported
+namedAtom :: LCSM.MonadSyntax LCSA.Atomic m => Text.Text -> m ()
+namedAtom expectName = do
+  name <- LCSC.atomName
+  Monad.unless (name == LCSA.AtomName expectName) LCSM.cut
+
+-- Helper, not exported
+x86RegTypes :: Ctx.Assignment LCT.TypeRepr (DMS.MacawCrucibleRegTypes X86.X86_64)
+x86RegTypes = DMS.crucArchRegTypes X86.x86_64MacawSymbolicFns
+
+-- Helper, not exported
+x86RegStructType :: LCT.TypeRepr (DMS.ArchRegStruct X86.X86_64)
+x86RegStructType = LCT.StructRepr x86RegTypes
+
+-- | Parser for type extensions to Crucible syntax
+x86TypeParser ::
+  LCSM.MonadSyntax LCSA.Atomic m =>
+  m (Some LCT.TypeRepr)
+x86TypeParser = do
+  namedAtom "X86Regs"
+  pure (Some x86RegStructType)
+
+---------------------------------------------------------------------
+-- Operations
+
+parseRegs ::
+  ( LCSM.MonadSyntax LCSA.Atomic m
+  , MonadIO m
+  , MonadState (LCSC.SyntaxState s) m
+  , MonadWriter [Posd (Stmt ext s)] m
+  , IsSyntaxExtension ext
+  , ?parserHooks :: LCSC.ParserHooks ext
+  ) =>
+  m (Atom s (DMS.ArchRegStruct X86.X86_64))
+parseRegs =
+  LCSM.describe "a struct of x86_64 register values" $ do
+    assign <- LCSC.operands (Ctx.Empty Ctx.:> x86RegStructType)
+    pure (assign Ctx.! Ctx.baseIndex)
+
+parseReg :: LCSM.MonadSyntax LCSA.Atomic m => m (Some (Ctx.Index (DMS.MacawCrucibleRegTypes X86.X86_64)))
+parseReg =
+  LCSM.describe "an x86_64 register" $ do
+    name <- LCSC.atomName
+    case name of
+      LCSA.AtomName "rip" -> pure (Some X86.rip)
+      LCSA.AtomName "rax" -> pure (Some X86.rax)
+      LCSA.AtomName "rbx" -> pure (Some X86.rbx)
+      LCSA.AtomName "rcx" -> pure (Some X86.rcx)
+      LCSA.AtomName "rdx" -> pure (Some X86.rdx)
+      LCSA.AtomName "rsp" -> pure (Some X86.rsp)
+      LCSA.AtomName "rbp" -> pure (Some X86.rbp)
+      LCSA.AtomName "rsi" -> pure (Some X86.rsi)
+      LCSA.AtomName "rdi" -> pure (Some X86.rdi)
+      LCSA.AtomName "r8" -> pure (Some X86.r8)
+      LCSA.AtomName "r9" -> pure (Some X86.r9)
+      LCSA.AtomName "r10" -> pure (Some X86.r10)
+      LCSA.AtomName "r11" -> pure (Some X86.r11)
+      LCSA.AtomName "r12" -> pure (Some X86.r12)
+      LCSA.AtomName "r13" -> pure (Some X86.r13)
+      LCSA.AtomName "r14" -> pure (Some X86.r14)
+      LCSA.AtomName "r15" -> pure (Some X86.r15)
+      LCSA.AtomName _ -> empty
+
+x86AtomParser ::
+  ( LCSM.MonadSyntax LCSA.Atomic m
+  , MonadIO m
+  , MonadState (LCSC.SyntaxState s) m
+  , MonadWriter [Posd (Stmt ext s)] m
+  , IsSyntaxExtension ext
+  , ?parserHooks :: LCSC.ParserHooks ext
+  ) =>
+  m (Some (Atom s))
+x86AtomParser =
+  LCSM.depCons LCSC.atomName $
+    \case
+      LCSA.AtomName "get-reg" -> do
+        loc <- LCSM.position
+        (Some reg, regs) <- LCSM.cons parseReg parseRegs
+        let regTy = x86RegTypes Ctx.! reg
+        Some <$> LCSC.freshAtom loc (Reg.EvalApp (Expr.GetStruct regs reg regTy))
+      LCSA.AtomName "set-reg" -> do
+        loc <- LCSM.position
+        LCSM.depCons parseReg $ \(Some reg) -> do
+          let regTy = x86RegTypes Ctx.! reg
+          assign <- LCSC.operands (Ctx.Empty Ctx.:> regTy Ctx.:> x86RegStructType)
+          let (rest, regs) = Ctx.decompose assign
+          let (Ctx.Empty, val) = Ctx.decompose rest
+          Some <$> LCSC.freshAtom loc (Reg.EvalApp (Expr.SetStruct x86RegTypes regs reg val))
+      LCSA.AtomName _ -> empty

macaw-x86-syntax/test-data/.gitignore

@@ -0,0 +1 @@
+*.out

macaw-x86-syntax/test-data/get-regs.cbl

@@ -0,0 +1,37 @@
+(defun @id ((regs X86Regs)) X86Regs
+  (start start:
+    (let vrip (get-reg rip regs))
+    (let vrax (get-reg rax regs))
+    (let vrbx (get-reg rbx regs))
+    (let vrcx (get-reg rcx regs))
+    (let vrdx (get-reg rdx regs))
+    (let vrsp (get-reg rsp regs))
+    (let vrbp (get-reg rbp regs))
+    (let vrsi (get-reg rsi regs))
+    (let vrdi (get-reg rdi regs))
+    (let vr8 (get-reg r8 regs))
+    (let vr9 (get-reg r9 regs))
+    (let vr10 (get-reg r10 regs))
+    (let vr11 (get-reg r11 regs))
+    (let vr12 (get-reg r12 regs))
+    (let vr13 (get-reg r13 regs))
+    (let vr14 (get-reg r14 regs))
+    (let vr15 (get-reg r15 regs))
+    (let regs0 (set-reg rip vrip regs))
+    (let regs1 (set-reg rax vrax regs0))
+    (let regs2 (set-reg rbx vrbx regs1))
+    (let regs3 (set-reg rcx vrcx regs2))
+    (let regs4 (set-reg rdx vrdx regs3))
+    (let regs5 (set-reg rsp vrsp regs4))
+    (let regs6 (set-reg rbp vrbp regs5))
+    (let regs7 (set-reg rsi vrsi regs6))
+    (let regs8 (set-reg rdi vrdi regs7))
+    (let regs9 (set-reg r8 vr8 regs8))
+    (let regs10 (set-reg r9 vr9 regs9))
+    (let regs11 (set-reg r10 vr10 regs10))
+    (let regs12 (set-reg r11 vr11 regs11))
+    (let regs13 (set-reg r12 vr12 regs12))
+    (let regs14 (set-reg r13 vr13 regs13))
+    (let regs15 (set-reg r14 vr14 regs14))
+    (let regs16 (set-reg r15 vr15 regs15))
+    (return regs16)))