GaloisInc/macaw
1
1
Fork 0
mirror of https://github.com/GaloisInc/macaw.git synced 2024-12-28 08:34:23 +03:00
Code Issues Projects Releases Wiki Activity

Generalize ArchFn result type.

Browse Source
This commit is contained in:
Joe Hendrix 2017-09-27 13:49:58 -07:00
parent 5617cd1429
commit 8a70d9aee4
No known key found for this signature in database
GPG Key ID: 8DFA5FF784098C4F
5 changed files with 41 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Data/Macaw/Architecture/Info.hs
View File

@ -4,6 +4,7 @@ Maintainer : jhendrix@galois.com
This defines the architecture-specific information needed for code discovery.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Data.Macaw.Architecture.Info
( ArchitectureInfo(..)
@ -75,7 +76,7 @@ data ArchitectureInfo arch
-- The address is the entry point of the function.
, absEvalArchFn :: !(forall ids tp
. AbsProcessorState (ArchReg arch) ids
-> ArchFn arch ids tp
-> ArchFn arch (Value arch ids) tp
-> AbsValue (RegAddrWidth (ArchReg arch)) tp)
-- ^ Evaluates an architecture-specific function
, absEvalArchStmt :: !(forall ids
@ -109,7 +110,9 @@ data ArchitectureInfo arch
-- should return 'Just stmts' if this code looks like a function return.
-- The stmts should be a subset of the statements, but may remove unneeded memory
-- accesses like reading the stack pointer.
, rewriteArchFn :: (forall src tgt tp . ArchFn arch src tp -> Rewriter arch src tgt (Value arch tgt tp))
, rewriteArchFn :: (forall src tgt tp
. ArchFn arch (Value arch src) tp
-> Rewriter arch src tgt (Value arch tgt tp))
-- ^ This rewrites an architecture specific statement
, rewriteArchStmt :: (forall src tgt . ArchStmt arch src -> Rewriter arch src tgt ())
-- ^ This rewrites an architecture specific statement

47
src/Data/Macaw/CFG/Core.hs
View File

@ -7,12 +7,12 @@ Defines data types needed to represent values, assignments, and statements from
This is a low-level CFG representation where the entire program is a
single CFG.
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PolyKinds #-}
@ -56,7 +56,7 @@ module Data.Macaw.CFG.Core
, ppValue
, ppStmt
, PrettyF(..)
, ArchConstraints(..)
, ArchConstraints
, PrettyRegValue(..)
-- * Architecture type families
, ArchFn
@ -70,16 +70,17 @@ module Data.Macaw.CFG.Core
, asStackAddrOffset
-- * References
, StmtHasRefs(..)
, FnHasRefs(..)
, refsInValue
, refsInApp
, refsInAssignRhs
, IsArchFn(..)
-- ** Synonyms
, ArchAddrWidth
, ArchAddrValue
, ArchAddrWord
, ArchMemAddr
, ArchSegmentOff
, Data.Parameterized.TraversableFC.FoldableFC(..)
) where
import Control.Exception (assert)
@ -96,6 +97,7 @@ import Data.Parameterized.NatRepr
import Data.Parameterized.Nonce
import Data.Parameterized.Some
import Data.Parameterized.TraversableF
import Data.Parameterized.TraversableFC (FoldableFC(..))
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as Set
@ -192,7 +194,7 @@ type family ArchReg (arch :: *) :: Type -> *
--
-- The function may depend on the set of registers defined so far, and the type
-- of the result.
type family ArchFn (arch :: *) :: * -> Type -> *
type family ArchFn (arch :: *) :: (Type -> *) -> Type -> *
-- | A type family for defining architecture-specific statements.
--
@ -306,7 +308,7 @@ data AssignRhs (arch :: *) ids tp where
-> AssignRhs arch ids tp
-- Call an architecture specific function that returns some result.
EvalArchFn :: !(ArchFn arch ids tp)
EvalArchFn :: !(ArchFn arch (Value arch ids) tp)
-> !(TypeRepr tp)
-> AssignRhs arch ids tp
@ -558,17 +560,13 @@ instance RegisterInfo (ArchReg arch) => Pretty (Value arch ids tp) where
instance RegisterInfo (ArchReg arch) => Show (Value arch ids tp) where
show = show . pretty
class ( RegisterInfo (ArchReg arch)
, PrettyF (ArchStmt arch)
, PrettyF (ArchTermStmt arch)
) => ArchConstraints arch where
-- | A function for pretty printing an archFn of a given type.
ppArchFn :: Applicative m
=> (forall u . Value arch ids u -> m Doc)
-- ^ Function for pretty printing vlaue.
-> ArchFn arch ids tp
-> m Doc
type ArchConstraints arch
= ( RegisterInfo (ArchReg arch)
, PrettyF (ArchStmt arch)
, PrettyF (ArchTermStmt arch)
, FoldableFC (ArchFn arch)
, IsArchFn (ArchFn arch)
)
-- | Pretty print an assignment right-hand side using operations parameterized
-- over an application to allow side effects.
@ -603,7 +601,7 @@ collectValueRep :: forall arch ids tp
=> Prec
-> Value arch ids tp
-> State (MapF (AssignId ids) DocF) Doc
collectValueRep _ (AssignedValue a :: Value arch ids tp) = do
collectValueRep _ (AssignedValue a) = do
let lhs = assignId a
mr <- gets $ MapF.lookup lhs
when (isNothing mr) $ do
@ -721,9 +719,14 @@ instance ArchConstraints arch => Show (Stmt arch ids) where
class StmtHasRefs f where
refsInStmt :: f ids -> Set (Some (AssignId ids))
-- | Return refernces in a function type.
class FnHasRefs (f :: * -> Type -> *) where
refsInFn :: f ids tp -> Set (Some (AssignId ids))
-- | Typeclass for folding over architecture-specific values.
class IsArchFn (f :: (k -> *) -> k -> *) where
-- | A function for pretty printing an archFn of a given type.
ppArchFn :: Applicative m
=> (forall u . v u -> m Doc)
-- ^ Function for pretty printing vlaue.
-> f v tp
-> m Doc
refsInValue :: Value arch ids tp -> Set (Some (AssignId ids))
refsInValue (AssignedValue (Assignment v _)) = Set.singleton (Some v)
@ -732,7 +735,7 @@ refsInValue _ = Set.empty
refsInApp :: App (Value arch ids) tp -> Set (Some (AssignId ids))
refsInApp app = foldApp refsInValue app
refsInAssignRhs :: FnHasRefs (ArchFn arch)
refsInAssignRhs :: FoldableFC (ArchFn arch)
=> AssignRhs arch ids tp
-> Set (Some (AssignId ids))
refsInAssignRhs rhs =
@ -740,4 +743,4 @@ refsInAssignRhs rhs =
EvalApp v -> refsInApp v
SetUndefined _ -> Set.empty
ReadMem v _ -> refsInValue v
EvalArchFn f _ -> refsInFn f
EvalArchFn f _ -> foldMapFC refsInValue f

4
src/Data/Macaw/CFG/DemandSet.hs
View File

@ -28,8 +28,8 @@ type AssignIdSet ids = Set (Some (AssignId ids))
-- resolve demand sets.
data DemandContext arch ids
= DemandContext { addArchStmtDemands :: !(ArchStmt arch ids -> DemandComp arch ids ())
, addArchFnDemands :: !(forall tp . ArchFn arch ids tp -> DemandComp arch ids ())
, archFnHasSideEffects :: !(forall tp . ArchFn arch ids tp -> Bool)
, addArchFnDemands :: !(forall tp . ArchFn arch (Value arch ids) tp -> DemandComp arch ids ())
, archFnHasSideEffects :: !(forall v tp . ArchFn arch v tp -> Bool)
-- ^ This returns true if the architecture function has implicit
-- side effects (and thus can be safely removed).
}

6
src/Data/Macaw/CFG/Rewriter.hs
View File

@ -40,7 +40,7 @@ data RewriteContext arch src tgt
= RewriteContext { rwctxNonceGen :: !(NonceGenerator (ST tgt) tgt)
-- ^ Generator for making new nonces in the target ST monad
, rwctxArchFn :: !(forall tp
. ArchFn arch src tp
. ArchFn arch (Value arch src) tp
-> Rewriter arch src tgt (Value arch tgt tp))
-- ^ Rewriter for architecture-specific statements
, rwctxArchStmt :: !(ArchStmt arch src -> Rewriter arch src tgt ())
@ -105,8 +105,8 @@ evalRewrittenRhs rhs = Rewriter $ do
pure $! AssignedValue a
-- | Add an assignment statement that evaluates the architecture function.
evalRewrittenArchFn :: HasRepr (ArchFn arch tgt) TypeRepr
=> ArchFn arch tgt tp
evalRewrittenArchFn :: HasRepr (ArchFn arch (Value arch tgt)) TypeRepr
=> ArchFn arch (Value arch tgt) tp
-> Rewriter arch src tgt (Value arch tgt tp)
evalRewrittenArchFn f = evalRewrittenRhs (EvalArchFn f (typeRepr f))

18
src/Data/Macaw/Fold.hs
View File

@ -6,11 +6,12 @@ This module provides a function for folding over the subexpressions in
a value without revisiting shared subterms.
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Macaw.Fold
( CanFoldValues(..)
( Data.Parameterized.TraversableFC.FoldableFC(..)
, foldValueCached
) where
@ -19,6 +20,7 @@ import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Parameterized.NatRepr
import Data.Parameterized.Some
import Data.Parameterized.TraversableFC
import Data.Macaw.CFG
@ -32,15 +34,7 @@ instance Monoid m => Monoid (StateMonadMonoid s m) where
mempty = return mempty
mappend m m' = mappend <$> m <*> m'
-- | Typeclass for folding over architecture-specific values.
class CanFoldValues arch where
-- | Folding over ArchFn values
foldFnValues :: Monoid r
=> (forall vtp . Value arch ids vtp -> r)
-> ArchFn arch ids tp
-> r
foldAssignRHSValues :: (Monoid r, CanFoldValues arch)
foldAssignRHSValues :: (Monoid r, FoldableFC (ArchFn arch))
=> (forall vtp . Value arch ids vtp -> r)
-> AssignRhs arch ids tp
-> r
@ -49,14 +43,14 @@ foldAssignRHSValues go v =
EvalApp a -> foldApp go a
SetUndefined _w -> mempty
ReadMem addr _ -> go addr
EvalArchFn f _ -> foldFnValues go f
EvalArchFn f _ -> foldMapFC go f
-- | This folds over elements of a values in a values.
--
-- It memoizes values so that it only evaluates assignments with the same id
-- once.
foldValueCached :: forall m arch ids tp
. (Monoid m, CanFoldValues arch)
. (Monoid m, FoldableFC (ArchFn arch))
=> (forall n. NatRepr n -> Integer -> m)
-- ^ Function for literals
-> (ArchMemAddr arch -> m)