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

Nearly done with semmc->macaw, need to complete addEltTH function

Browse Source
This commit is contained in:
Ben Selfridge 2017-10-17 12:27:57 -07:00
parent db2da637b0
commit 0649ea4f0c
3 changed files with 81 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
macaw-ppc/src/Data/Macaw/PPC/Operand.hs
View File

@ -30,7 +30,7 @@ import qualified SemMC.Architecture.PPC64 as PPC64
import qualified Data.Macaw.PPC.PPCReg as R import qualified Data.Macaw.PPC.PPCReg as R
import qualified Data.Macaw.PPC.Generator as G import qualified Data.Macaw.PPC.Generator as G
class ExtractValue arch a tp where class ExtractValue arch a tp | arch a -> tp where
extractValue :: a -> G.PPCGenerator arch s (MC.Value arch s tp) extractValue :: a -> G.PPCGenerator arch s (MC.Value arch s tp)
instance ExtractValue PPC32.PPC D.GPR (BVType 32) where instance ExtractValue PPC32.PPC D.GPR (BVType 32) where

1
macaw-ppc/src/Data/Macaw/PPC/PPCReg.hs
View File

@ -40,6 +40,7 @@ data PPCReg arch tp where
PPC_LNK :: (w ~ MC.RegAddrWidth (PPCReg arch), 1 <= w) => PPCReg arch (BVType w) PPC_LNK :: (w ~ MC.RegAddrWidth (PPCReg arch), 1 <= w) => PPCReg arch (BVType w)
PPC_CTR :: (w ~ MC.RegAddrWidth (PPCReg arch), 1 <= w) => PPCReg arch (BVType w) PPC_CTR :: (w ~ MC.RegAddrWidth (PPCReg arch), 1 <= w) => PPCReg arch (BVType w)
PPC_CR :: PPCReg arch (BVType 32) PPC_CR :: PPCReg arch (BVType 32)
PPC_XER :: (w ~ MC.RegAddrWidth (PPCReg arch), 1 <= w) => PPCReg arch (BVType w)
deriving instance Eq (PPCReg arch tp) deriving instance Eq (PPCReg arch tp)
deriving instance Ord (PPCReg arch tp) deriving instance Ord (PPCReg arch tp)

160
macaw-ppc/src/Data/Macaw/PPC/Semantics/TH.hs
View File

@ -278,7 +278,7 @@ translateFormula :: forall arch t sh .
-> BoundVarInterpretations arch t -> BoundVarInterpretations arch t
-> SL.ShapedList (FreeParamF Name) sh -> SL.ShapedList (FreeParamF Name) sh
-> Q Exp -> Q Exp
translateFormula semantics bvInterps varNames = do translateFormula semantics interps varNames = do
let exps = map translateDefinition (Map.toList (pfDefs semantics)) let exps = map translateDefinition (Map.toList (pfDefs semantics))
[| Just $(doSequenceQ exps) |] [| Just $(doSequenceQ exps) |]
where translateDefinition :: Map.Pair (Parameter arch sh) (S.SymExpr (Sym t)) where translateDefinition :: Map.Pair (Parameter arch sh) (S.SymExpr (Sym t))
@ -286,13 +286,13 @@ translateFormula semantics bvInterps varNames = do
translateDefinition (Map.Pair param expr) = do translateDefinition (Map.Pair param expr) = do
case param of case param of
OperandParameter w idx -> do OperandParameter w idx -> do
e <- addEltTH bvInterps expr e <- addEltTH interps expr
let FreeParamF name = varNames `SL.indexShapedList` idx let FreeParamF name = varNames `SL.indexShapedList` idx
[| do val <- $(return e) [| do val <- $(return e)
let reg = toPPCReg $(varE name) let reg = toPPCReg $(varE name)
curPPCState . M.boundValue reg .= val |] curPPCState . M.boundValue reg .= val |]
LiteralParameter loc -> do LiteralParameter loc -> do
e <- addEltTH bvInterps expr e <- addEltTH interps expr
reg <- locToRegTH (Proxy @arch) loc reg <- locToRegTH (Proxy @arch) loc
[| do val <- $(return e) [| do val <- $(return e)
curPPCState . M.boundValue $(return reg) .= val |] curPPCState . M.boundValue $(return reg) .= val |]
@ -305,18 +305,18 @@ addEltTH :: forall arch t ctp .
=> BoundVarInterpretations arch t => BoundVarInterpretations arch t
-> S.Elt t ctp -> S.Elt t ctp
-> Q Exp -> Q Exp
addEltTH bvInterps elt = case elt of addEltTH interps elt = case elt of
S.BVElt w val loc -> S.BVElt w val loc ->
[| return (M.BVValue $(natReprTH w) $(lift val)) |] [| return (M.BVValue $(natReprTH w) $(lift val)) |]
S.AppElt appElt -> do S.AppElt appElt -> do
let app = S.appEltApp appElt let app = S.appEltApp appElt
appExpr <- crucAppToExprTH app bvInterps appExpr <- crucAppToExprTH app interps
[| $(crucAppToExprTH (S.appEltApp appElt) bvInterps) >>= addExpr |] [| $(crucAppToExprTH (S.appEltApp appElt) interps) >>= addExpr |]
S.BoundVarElt bVar -> S.BoundVarElt bVar ->
case Map.lookup bVar (locVars bvInterps) of case Map.lookup bVar (locVars interps) of
Just loc -> [| getRegValue $(locToRegTH (Proxy @arch) loc) |] Just loc -> [| getRegValue $(locToRegTH (Proxy @arch) loc) |]
Nothing -> Nothing ->
case Map.lookup bVar (opVars bvInterps) of case Map.lookup bVar (opVars interps) of
Just (FreeParamF name) -> [| extractValue $(varE name) |] Just (FreeParamF name) -> [| extractValue $(varE name) |]
Nothing -> fail $ "bound var not found: " ++ show bVar Nothing -> fail $ "bound var not found: " ++ show bVar
_ -> [| error "addEltTH" |] _ -> [| error "addEltTH" |]
@ -341,68 +341,68 @@ crucAppToExprTH :: (L.Location arch ~ APPC.Location arch,
=> S.App (S.Elt t) ctp => S.App (S.Elt t) ctp
-> BoundVarInterpretations arch t -> BoundVarInterpretations arch t
-> Q Exp -> Q Exp
crucAppToExprTH elt bvInterps = case elt of crucAppToExprTH elt interps = case elt of
S.TrueBool -> [| return $ ValueExpr (M.BoolValue True) |] S.TrueBool -> [| return $ ValueExpr (M.BoolValue True) |]
S.FalseBool -> [| return $ ValueExpr (M.BoolValue False) |] S.FalseBool -> [| return $ ValueExpr (M.BoolValue False) |]
S.NotBool bool -> S.NotBool bool ->
[| AppExpr <$> (M.NotApp <$> $(addEltTH bvInterps bool)) |] [| AppExpr <$> (M.NotApp <$> $(addEltTH interps bool)) |]
S.AndBool bool1 bool2 -> S.AndBool bool1 bool2 ->
[| AppExpr <$> (M.AndApp <$> $(addEltTH bvInterps bool1) <*> $(addEltTH bvInterps bool2)) |] [| AppExpr <$> (M.AndApp <$> $(addEltTH interps bool1) <*> $(addEltTH interps bool2)) |]
S.XorBool bool1 bool2 -> S.XorBool bool1 bool2 ->
[| AppExpr <$> (M.XorApp <$> $(addEltTH bvInterps bool1) <*> $(addEltTH bvInterps bool2)) |] [| AppExpr <$> (M.XorApp <$> $(addEltTH interps bool1) <*> $(addEltTH interps bool2)) |]
S.IteBool test t f -> S.IteBool test t f ->
[| AppExpr <$> (M.Mux M.BoolTypeRepr [| AppExpr <$> (M.Mux M.BoolTypeRepr
<$> $(addEltTH bvInterps test) <$> $(addEltTH interps test)
<*> $(addEltTH bvInterps t) <*> $(addEltTH interps t)
<*> $(addEltTH bvInterps f)) |] <*> $(addEltTH interps f)) |]
S.BVIte w numBranches test t f -> S.BVIte w numBranches test t f ->
[| AppExpr <$> (M.Mux (M.BVTypeRepr $(natReprTH w)) [| AppExpr <$> (M.Mux (M.BVTypeRepr $(natReprTH w))
<$> $(addEltTH bvInterps test) <$> $(addEltTH interps test)
<*> $(addEltTH bvInterps t) <*> $(addEltTH interps t)
<*> $(addEltTH bvInterps f)) |] <*> $(addEltTH interps f)) |]
S.BVEq bv1 bv2 -> S.BVEq bv1 bv2 ->
[| AppExpr <$> (M.Eq <$> $(addEltTH bvInterps bv1) <*> $(addEltTH bvInterps bv2)) |] [| AppExpr <$> (M.Eq <$> $(addEltTH interps bv1) <*> $(addEltTH interps bv2)) |]
S.BVSlt bv1 bv2 -> S.BVSlt bv1 bv2 ->
[| AppExpr <$> (M.BVSignedLt <$> $(addEltTH bvInterps bv1) <*> $(addEltTH bvInterps bv2)) |] [| AppExpr <$> (M.BVSignedLt <$> $(addEltTH interps bv1) <*> $(addEltTH interps bv2)) |]
S.BVUlt bv1 bv2 -> S.BVUlt bv1 bv2 ->
[| AppExpr <$> (M.BVUnsignedLt <$> $(addEltTH bvInterps bv1) <*> $(addEltTH bvInterps bv2)) |] [| AppExpr <$> (M.BVUnsignedLt <$> $(addEltTH interps bv1) <*> $(addEltTH interps bv2)) |]
S.BVConcat w bv1 bv2 -> do S.BVConcat w bv1 bv2 -> do
[| error "BVConcat" |] let u = S.bvWidth bv1
-- [| AppExpr (M.BVUnsignedLt <$> $(addEltTH bvInterps bv1) <*> $(addEltTH bvInterps bv2)) |] v = S.bvWidth bv2
-- let u = S.bvWidth bv1 [| do bv1Val <- $(addEltTH interps bv1)
-- v = S.bvWidth bv2 bv2Val <- $(addEltTH interps bv2)
-- bv1Val <- addElt bv1 S.LeqProof <- return $ S.leqAdd2 (S.leqRefl $(natReprTH u)) (S.leqProof (knownNat @1) $(natReprTH v))
-- bv2Val <- addElt bv2 pf1@S.LeqProof <- return $ S.leqAdd2 (S.leqRefl $(natReprTH v)) (S.leqProof (knownNat @1) $(natReprTH u))
-- S.LeqProof <- return $ S.leqAdd2 (S.leqRefl u) (S.leqProof (knownNat @1) v) Refl <- return $ S.plusComm $(natReprTH u) $(natReprTH v)
-- S.LeqProof <- return $ S.leqAdd2 (S.leqRefl v) (S.leqProof (knownNat @1) u) bv1Ext <- addExpr (AppExpr (M.UExt bv1Val $(natReprTH w)))
-- Refl <- return $ S.plusComm u v -- bv2Ext <- addExpr (AppExpr (M.UExt bv2Val $(natReprTH w)))
-- bv1Ext <- addExpr (AppExpr (M.UExt bv1Val w)) ---(u `addNat` v))) bv1Shifter <- addExpr (ValueExpr (M.BVValue $(natReprTH w) (natValue $(natReprTH v))))
-- bv2Ext <- addExpr (AppExpr (M.UExt bv2Val w)) bv1Shf <- addExpr (AppExpr (M.BVShl $(natReprTH w) bv1Ext bv1Shifter))
-- bv1Shifter <- addExpr (ValueExpr (M.BVValue w (natValue v))) return $ AppExpr (M.BVOr $(natReprTH w) bv1Shf (M.mkLit $(natReprTH w) 1)) |]
-- bv1Shf <- addExpr (AppExpr (M.BVShl w bv1Ext bv1Shifter))
-- return $ M.BVOr w bv1Shf bv2Ext
S.BVSelect idx n bv -> do S.BVSelect idx n bv -> do
[| error "BVSelect" |] let w = S.bvWidth bv
-- let w = S.bvWidth bv [| do bvVal <- $(addEltTH interps bv)
-- bvVal <- addElt bv case natValue $(natReprTH n) + 1 <= natValue $(natReprTH w) of
-- case natValue n + 1 <= natValue w of True -> do
-- True -> do -- Is there a way to just "know" that n + 1 <= w?
-- -- Is there a way to just "know" that n + 1 <= w? Just S.LeqProof <- return $ S.testLeq ($(natReprTH n) `addNat` (knownNat @1)) $(natReprTH w)
-- Just S.LeqProof <- return $ S.testLeq (n `addNat` (knownNat @1)) w pf1@S.LeqProof <- return $ S.leqAdd2 (S.leqRefl $(natReprTH idx)) (S.leqProof (knownNat @1) $(natReprTH n))
-- pf1@S.LeqProof <- return $ S.leqAdd2 (S.leqRefl idx) (S.leqProof (knownNat @1) n) pf2@S.LeqProof <- return $ S.leqAdd (S.leqRefl (knownNat @1)) $(natReprTH idx)
-- pf2@S.LeqProof <- return $ S.leqAdd (S.leqRefl (knownNat @1)) idx Refl <- return $ S.plusComm (knownNat @1) $(natReprTH idx)
-- Refl <- return $ S.plusComm (knownNat @1) idx pf3@S.LeqProof <- return $ S.leqTrans pf2 pf1
-- pf3@S.LeqProof <- return $ S.leqTrans pf2 pf1 S.LeqProof <- return $ S.leqTrans pf3 (S.leqProof ($(natReprTH idx) `addNat` $(natReprTH n)) $(natReprTH w))
-- S.LeqProof <- return $ S.leqTrans pf3 (S.leqProof (idx `addNat` n) w) bvShf <- addExpr (AppExpr (M.BVShr $(natReprTH w) bvVal (M.mkLit $(natReprTH w) (natValue $(natReprTH idx)))))
-- bvShf <- addExpr (AppExpr (M.BVShr w bvVal (M.mkLit w (natValue idx)))) return $ AppExpr (M.Trunc bvShf $(natReprTH n))
-- return $ AppExpr (M.Trunc bvShf n) False -> do
-- False -> do -- Is there a way to just "know" that n = w?
-- -- Is there a way to just "know" that n = w? -- Just Refl <- return $ testEquality $(natReprTH n) $(natReprTH w)
-- Just Refl <- return $ testEquality n w -- return $ ValueExpr bvVal
-- return $ ValueExpr bvVal error "BVSelect called with equal widths"
|]
S.BVNeg w bv -> do S.BVNeg w bv -> do
-- Note: This is still untested -- Note: This is still untested
[| do bvVal <- $(addEltTH bvInterps bv) [| do bvVal <- $(addEltTH interps bv)
bvComp <- addExpr (AppExpr (M.BVComplement $(natReprTH w) bvVal)) bvComp <- addExpr (AppExpr (M.BVComplement $(natReprTH w) bvVal))
return $ AppExpr (M.BVAdd $(natReprTH w) bvComp (M.mkLit $(natReprTH w) 1)) |] return $ AppExpr (M.BVAdd $(natReprTH w) bvComp (M.mkLit $(natReprTH w) 1)) |]
-- bvVal <- addElt bv -- bvVal <- addElt bv
@ -412,51 +412,47 @@ crucAppToExprTH elt bvInterps = case elt of
-- Note: below is untested, could be wrong. -- Note: below is untested, could be wrong.
[| do let bitExp = ValueExpr (M.BVValue $(natReprTH (S.bvWidth bv)) $(lift idx)) [| do let bitExp = ValueExpr (M.BVValue $(natReprTH (S.bvWidth bv)) $(lift idx))
bitExpVal <- addExpr bitExp bitExpVal <- addExpr bitExp
AppExpr <$> (M.BVTestBit <$> bitExpVal <*> $(addEltTH bvInterps bv)) |] AppExpr <$> (M.BVTestBit <$> bitExpVal <*> $(addEltTH interps bv)) |]
S.BVAdd w bv1 bv2 -> S.BVAdd w bv1 bv2 ->
[| AppExpr <$> (M.BVAdd $(natReprTH w) [| AppExpr <$> (M.BVAdd $(natReprTH w)
<$> $(addEltTH bvInterps bv1) <$> $(addEltTH interps bv1)
<*> $(addEltTH bvInterps bv2)) |] <*> $(addEltTH interps bv2)) |]
S.BVMul w bv1 bv2 -> S.BVMul w bv1 bv2 ->
[| AppExpr <$> (M.BVMul $(natReprTH w) [| AppExpr <$> (M.BVMul $(natReprTH w)
<$> $(addEltTH bvInterps bv1) <$> $(addEltTH interps bv1)
<*> $(addEltTH bvInterps bv2)) |] <*> $(addEltTH interps bv2)) |]
S.BVShl w bv1 bv2 -> S.BVShl w bv1 bv2 ->
[| AppExpr <$> (M.BVShl $(natReprTH w) [| AppExpr <$> (M.BVShl $(natReprTH w)
<$> $(addEltTH bvInterps bv1) <$> $(addEltTH interps bv1)
<*> $(addEltTH bvInterps bv2)) |] <*> $(addEltTH interps bv2)) |]
S.BVLshr w bv1 bv2 -> S.BVLshr w bv1 bv2 ->
[| AppExpr <$> (M.BVShr $(natReprTH w) [| AppExpr <$> (M.BVShr $(natReprTH w)
<$> $(addEltTH bvInterps bv1) <$> $(addEltTH interps bv1)
<*> $(addEltTH bvInterps bv2)) |] <*> $(addEltTH interps bv2)) |]
S.BVAshr w bv1 bv2 -> S.BVAshr w bv1 bv2 ->
[| AppExpr <$> (M.BVSar $(natReprTH w) [| AppExpr <$> (M.BVSar $(natReprTH w)
<$> $(addEltTH bvInterps bv1) <$> $(addEltTH interps bv1)
<*> $(addEltTH bvInterps bv2)) |] <*> $(addEltTH interps bv2)) |]
S.BVZext w bv -> S.BVZext w bv ->
-- [| AppExpr <$> (M.UExt <$> $(addEltTH bvInterps bv) <*> (pure $(natReprTH w))) |] [| AppExpr <$> (M.UExt <$> $(addEltTH interps bv) <*> (pure $(natReprTH w))) |]
[| undefined |]
-- [| do val <- $(addEltTH bvInterps bv)
-- return $ AppExpr (M.UExt val $(natReprTH w)) |]
S.BVSext w bv -> S.BVSext w bv ->
-- [| AppExpr <$> (M.SExt <$> $(addEltTH bvInterps bv) <*> (pure $(natReprTH w))) |] [| AppExpr <$> (M.SExt <$> $(addEltTH interps bv) <*> (pure $(natReprTH w))) |]
[| undefined |]
S.BVTrunc w bv -> S.BVTrunc w bv ->
[| AppExpr <$> (M.Trunc <$> $(addEltTH bvInterps bv) <*> (pure $(natReprTH w))) |] [| AppExpr <$> (M.Trunc <$> $(addEltTH interps bv) <*> (pure $(natReprTH w))) |]
S.BVBitNot w bv -> S.BVBitNot w bv ->
[| AppExpr <$> (M.BVComplement $(natReprTH w) <$> $(addEltTH bvInterps bv)) |] [| AppExpr <$> (M.BVComplement $(natReprTH w) <$> $(addEltTH interps bv)) |]
S.BVBitAnd w bv1 bv2 -> S.BVBitAnd w bv1 bv2 ->
[| AppExpr <$> (M.BVAnd $(natReprTH w) [| AppExpr <$> (M.BVAnd $(natReprTH w)
<$> $(addEltTH bvInterps bv1) <$> $(addEltTH interps bv1)
<*> $(addEltTH bvInterps bv2)) |] <*> $(addEltTH interps bv2)) |]
S.BVBitOr w bv1 bv2 -> S.BVBitOr w bv1 bv2 ->
[| AppExpr <$> (M.BVOr $(natReprTH w) [| AppExpr <$> (M.BVOr $(natReprTH w)
<$> $(addEltTH bvInterps bv1) <$> $(addEltTH interps bv1)
<*> $(addEltTH bvInterps bv2)) |] <*> $(addEltTH interps bv2)) |]
S.BVBitXor w bv1 bv2 -> S.BVBitXor w bv1 bv2 ->
[| AppExpr <$> (M.BVXor $(natReprTH w) [| AppExpr <$> (M.BVXor $(natReprTH w)
<$> $(addEltTH bvInterps bv1) <$> $(addEltTH interps bv1)
<*> $(addEltTH bvInterps bv2)) |] <*> $(addEltTH interps bv2)) |]
_ -> [| error "unsupported Crucible elt" |] _ -> [| error "unsupported Crucible elt" |]
@ -485,8 +481,9 @@ crucAppToExpr (S.BVConcat w bv1 bv2) = AppExpr <$> do
bv1Val <- addElt bv1 bv1Val <- addElt bv1
bv2Val <- addElt bv2 bv2Val <- addElt bv2
S.LeqProof <- return $ S.leqAdd2 (S.leqRefl u) (S.leqProof (knownNat @1) v) S.LeqProof <- return $ S.leqAdd2 (S.leqRefl u) (S.leqProof (knownNat @1) v)
S.LeqProof <- return $ S.leqAdd2 (S.leqRefl v) (S.leqProof (knownNat @1) u) pf1@S.LeqProof <- return $ S.leqAdd2 (S.leqRefl v) (S.leqProof (knownNat @1) u)
Refl <- return $ S.plusComm u v Refl <- return $ S.plusComm u v
S.LeqProof <- return $ S.leqTrans pf1 (S.leqRefl w)
bv1Ext <- addExpr (AppExpr (M.UExt bv1Val w)) ---(u `addNat` v))) bv1Ext <- addExpr (AppExpr (M.UExt bv1Val w)) ---(u `addNat` v)))
bv2Ext <- addExpr (AppExpr (M.UExt bv2Val w)) bv2Ext <- addExpr (AppExpr (M.UExt bv2Val w))
bv1Shifter <- addExpr (ValueExpr (M.BVValue w (natValue v))) bv1Shifter <- addExpr (ValueExpr (M.BVValue w (natValue v)))
@ -568,7 +565,8 @@ locToRegTH _ APPC.LocIP = [| PPC_IP |]
locToRegTH _ APPC.LocLNK = [| PPC_LNK |] locToRegTH _ APPC.LocLNK = [| PPC_LNK |]
locToRegTH _ APPC.LocCTR = [| PPC_CTR |] locToRegTH _ APPC.LocCTR = [| PPC_CTR |]
locToRegTH _ APPC.LocCR = [| PPC_CR |] locToRegTH _ APPC.LocCR = [| PPC_CR |]
locToRegTH _ _ = [| undefined |] locToRegTH _ APPC.LocXER = [| PPC_XER |]
locToRegTH _ loc = [| undefined |]
-- fill the rest out later -- fill the rest out later
-- | Given a location to modify and a crucible formula, construct a PPCGenerator that -- | Given a location to modify and a crucible formula, construct a PPCGenerator that