WIP: funptr

cabal.project

@@ -21,7 +21,8 @@ tests: true
 
 -- NOTE: This applies to the whole package: reopt and reopt-explore
 package reopt
-  ghc-options: -Wall -Werror
+  ghc-options: -Wall -Wno-error=unused-imports -Wno-error=unused-do-bind -Wno-error=unused-pattern-binds
+  -- ghc-options: -Wall -Werror
 package reopt-tools
   ghc-options: -Wall
 package reopt-vcg-ann

src/Reopt.hs

@@ -307,7 +307,7 @@ import Reopt.TypeInference.FunTypeMaps (
  )
 import Reopt.TypeInference.Header (parseHeader)
 import Reopt.TypeInference.HeaderTypes (
-  AnnDeclarations (funDecls),
+  AnnDeclarations (..),
   AnnFunArg (..),
   AnnFunType (..),
   AnnType (..),
@@ -377,7 +377,7 @@ import Reopt.X86 (
   osPersonality,
   x86OSForABI,
  )
-
+import Debug.Trace
 copyrightNotice :: String
 copyrightNotice = "Copyright 2014-21 Galois, Inc."
 
@@ -669,7 +669,8 @@ logDiscEventAsReoptEvents logger symMap evt = do
     Macaw.ReportIdentifyFunction a tgt rsn -> do
       let msg =
             printf
-              "Candidate function %s %s."
+              -- ppFunReason will add a space if needed
+              "Candidate function %s%s."
               (Events.ppFnEntry (Map.lookup tgt symMap) tgt)
               (Macaw.ppFunReason rsn)
       logger $ Events.ReoptFunStepLog Events.Discovery (mkFunId a) msg
@@ -1708,6 +1709,12 @@ headerTypeMap ::
   Map (ArchSegmentOff arch) Macaw.NoReturnFunStatus ->
   ReoptM arch r (FunTypeMaps (Macaw.ArchAddrWidth arch))
 headerTypeMap hdrAnn dynDepsTypeMap symAddrMap noretMap = do
+
+  trace "typeDefs" $ forM_ (Map.assocs (typeDefs hdrAnn)) $ \ (bs, ty) ->
+    trace (show bs <> " ↦ " <> show ty) (pure ())
+  trace "funDecls" $ forM_ (Map.assocs (funDecls hdrAnn)) $ \ (bs, ty) ->
+    trace (show bs <> " ↦ " <> show ty) (pure ())
+
   globalStepStarted Events.HeaderTypeInference
 
   let voidPtrType = PtrAnnType VoidAnnType
@@ -1751,14 +1758,15 @@ headerTypeMap hdrAnn dynDepsTypeMap symAddrMap noretMap = do
         ReoptM arch r (Map (ArchSegmentOff arch) ReoptFunType)
       insSymType m (sym, annTp) = do
         case symAddrMapLookup symAddrMap sym of
-          Left SymAddrMapNotFound -> do
-            -- Silently drop symbols without addresses as they may be undefined.
-            pure m
+          -- Silently drop symbols without addresses as they may be undefined.
+          Left SymAddrMapNotFound -> pure m
           Left SymAddrMapAmbiguous -> do
             globalStepWarning Events.HeaderTypeInference $
-              "Ambiguous symbol " ++ BSC.unpack sym ++ "."
+              "Ambiguous symbol " ++ BSC.unpack sym
             pure m
           Right addr -> do
+            globalStepWarning Events.HeaderTypeInference $
+              "SUCCESS: symbol " ++ BSC.unpack sym
             pure $! Map.insert addr annTp m
     foldlM insSymType Map.empty (Map.toList nameAnnTypeMap)
 
@@ -2089,6 +2097,8 @@ resolveArgType nm tp0 =
       addGPReg64 nm
     TypedefAnnType _ tp ->
       resolveArgType nm tp
+    FunPtrAnnType _ret _args ->
+      addGPReg64 nm
 
 -- | This parses the types extracted from header function arguments to the
 -- machine code registers that the function will expect.
@@ -2120,6 +2130,7 @@ parseReturnType tp0 =
     DoubleAnnType -> Right [Some (RetZMM ZMMDouble 0)]
     PtrAnnType _ -> Right [Some (RetBV64 F.RAX)]
     TypedefAnnType _ tp -> parseReturnType tp
+    FunPtrAnnType{} -> Left $ UnsupportedReturnType (ppAnnType tp0)
 
 resolveAnnFunType ::
   Monad m =>
@@ -2253,15 +2264,16 @@ x86ArgumentAnalysis ::
   -- | Map from addresses to function name.
   (MemSegmentOff 64 -> Maybe BSC.ByteString) ->
   -- | Map from address to the name at that address along with type
-  (BSC.ByteString -> Maybe X86FunTypeInfo) ->
+  Map BSC.ByteString (MemSegmentOff 64, X86FunTypeInfo) ->
   Macaw.DiscoveryState X86_64 ->
   ReoptM
     X86_64
     r
     ( Map (MemSegmentOff 64) X86FunTypeInfo
     , Map (MemSegmentOff 64) (FunctionArgAnalysisFailure 64)
     )
-x86ArgumentAnalysis sysp resolveFunName resolveFunType discState = do
+x86ArgumentAnalysis sysp resolveFunName funTypeMap discState = do
+  let resolveFunType fnm = snd <$> Map.lookup fnm funTypeMap
   -- Generate map from symbol names to known type.
   let mem = Macaw.memory discState
   -- Compute only those functions whose types are not known.
@@ -2282,9 +2294,11 @@ x86ArgumentAnalysis sysp resolveFunName resolveFunType discState = do
             RegState X86Reg (Value X86_64 ids) ->
             Either String [Some (Value X86_64 ids)]
           resolveFn callSite callRegs = do
-            case x86CallRegs mem resolveFunName resolveFunType callSite callRegs of
-              Left rsn -> Left (ppRegisterUseErrorReason rsn)
-              Right r -> Right (callArgValues r)
+            -- trace ("[!!!] Resolving " <> show callSite <> ", regs: " <> show callRegs) $
+            trace ("FunMap:\n" <> show funTypeMap) $
+              case x86CallRegs mem resolveFunName resolveFunType callSite callRegs of
+                Left rsn -> trace "Left" $ Left (ppRegisterUseErrorReason rsn)
+                Right r -> trace "Right" $ Right (callArgValues r)
         functionDemands (x86DemandInfo sysp) mem resolveFn $
           filter shouldPropagate $
             Macaw.exploredFunctions discState
@@ -2320,6 +2334,11 @@ doRecoverX86 ::
   Macaw.DiscoveryState X86_64 ->
   ReoptM X86_64 r RecoverX86Output
 doRecoverX86 unnamedFunPrefix sysp symAddrMap debugTypeMap discState = do
+
+  trace "Potential fun type map:" $
+    forM_ (Map.assocs (addrTypeMap debugTypeMap)) $ \ (k, v) -> do
+      trace (show k <> " ↦ " <> show v) (pure ())
+
   -- Map names to known function types when we have explicit information.
   let
     knownFunTypeMap :: Map BS.ByteString (MemSegmentOff 64, X86FunTypeInfo)
@@ -2353,11 +2372,20 @@ doRecoverX86 unnamedFunPrefix sysp symAddrMap debugTypeMap discState = do
                   Nothing -> nosymFunctionName unnamedFunPrefix addr
           ]
 
-  -- Infer registers each function demands.
+ -- Infer registers each function demands.
   (fDems, summaryFailures) <- do
     let resolveFunName a = Map.lookup a funNameMap
-    let resolveFunType fnm = snd <$> Map.lookup fnm knownFunTypeMap
-    x86ArgumentAnalysis sysp resolveFunName resolveFunType discState
+    x86ArgumentAnalysis sysp resolveFunName knownFunTypeMap discState
+
+  let explored =
+        [ nm
+        | Some finfo <- Macaw.exploredFunctions discState
+        , let faddr = Macaw.discoveredFunAddr finfo
+        , let nm = Map.findWithDefault (error "Address undefined in funNameMap") faddr funNameMap
+        ]
+
+  trace "Functions explored by Macaw:" $ forM_ explored $ \ nm ->
+    trace (" → " <> show nm) (pure ())
 
   let
     funTypeMap :: Map BS.ByteString (MemSegmentOff 64, X86FunTypeInfo)
@@ -2371,44 +2399,63 @@ doRecoverX86 unnamedFunPrefix sysp symAddrMap debugTypeMap discState = do
           , tp <- maybeToList $ Map.lookup faddr fDems
           ]
 
+  trace "fDems:" $ forM_ (Map.assocs fDems) $ \ (k, v) ->
+    trace (show k <> " ↦ " <> show v) (pure ())
+  trace "Candidates were:" (pure ())
+  forM_
+          [ (faddr, nm)
+          | Some finfo <- Macaw.exploredFunctions discState
+          , let faddr = Macaw.discoveredFunAddr finfo
+          , let nm = Map.findWithDefault (error "Address undefined in funNameMap") faddr funNameMap
+          -- , tp <- maybeToList $ Map.lookup faddr fDems
+          ] $ \ (a, nm) ->
+            trace (show a <> " ↦ " <> show nm) (pure ())
+
+  trace "Actual fun type map:" $
+    forM_ (Map.assocs funTypeMap) $ \ kv -> do
+      trace (show kv) (pure ())
+
   fnDefsAndLogEvents <- fmap catMaybes $
     forM (Macaw.exploredFunctions discState) $ \(Some finfo) -> do
+     trace ("Considering recovering " <> show (Macaw.discoveredFunAddr finfo)) $ do
       let faddr = Macaw.discoveredFunAddr finfo
+      let _ = trace ("2: " <> show faddr) ()
       let dnm = Macaw.discoveredFunSymbol finfo
       let fnId = Events.funId faddr dnm
       let nm = Map.findWithDefault (error "Address undefined in funNameMap") faddr funNameMap
+      let abandonBecause reason = trace ("Abandoning " <> show nm <> " because " <> reason) (pure Nothing)
       case snd <$> Map.lookup nm funTypeMap of
         Nothing -> do
           -- TODO: Check an error has already been reported on this.
-          pure Nothing
+          abandonBecause "we don't know its type"
         Just (X86PrintfFunType _) -> do
           -- Var-args cannot be recovered.
-          pure Nothing
+          abandonBecause "it is variadic"
         Just X86OpenFunType -> do
           -- open cannot be recovered.
-          pure Nothing
+          abandonBecause "the open function cannot be recovered"
         Just (X86NonvarargFunType argRegs retRegs) -> do
           case checkFunction finfo of
             FunctionIncomplete _errTag -> do
-              pure Nothing
+              abandonBecause "the function is incomplete"
             FunctionHasPLT -> do
-              pure Nothing
+              abandonBecause "the function has a PLT"
             FunctionOK -> do
               funStepStarted Events.InvariantInference fnId
               let resolveFunName a = Map.lookup a funNameMap
               let resolveFunType fnm = snd <$> Map.lookup fnm funTypeMap
               case x86BlockInvariants sysp mem resolveFunName resolveFunType finfo retRegs of
                 Left e -> do
                   funStepFailed Events.InvariantInference fnId e
-                  pure Nothing
+                  abandonBecause "we could not infer invariants"
                 Right invMap -> do
                   funStepFinished Events.InvariantInference fnId invMap
                   -- Do function recovery
                   funStepStarted Events.Recovery fnId
                   case recoverFunction sysp mem finfo invMap nm argRegs retRegs of
                     Left e -> do
                       funStepFailed Events.Recovery fnId e
-                      pure Nothing
+                      abandonBecause $ "recovery failed: " <> show (Events.recoverErrorMessage e)
                     Right fn -> do
                       funStepFinished Events.Recovery fnId ()
                       pure (Just fn)
@@ -2712,7 +2759,8 @@ renderLLVMBitcode llvmGenOpt cfg os recMod constraints =
   -- Generate LLVM module
   let
     archOps = LLVM.x86LLVMArchOps (show os)
-    (m, ann, ext, logEvents) = moduleForFunctions archOps llvmGenOpt recMod constraints
+    aInfo = osArchitectureInfo os
+    (m, ann, ext, logEvents) = moduleForFunctions aInfo archOps llvmGenOpt recMod constraints
     -- Render into LLVM
     out = HPJ.fullRender HPJ.PageMode 10000 1 pp mempty (ppLLVM cfg m)
    in

src/Reopt/CFG/FnRep.hs

@@ -69,7 +69,7 @@ import Data.Macaw.CFG (
   ppApp,
   sexpr,
  )
-import Data.Macaw.Memory
+import Data.Macaw.Memory qualified as Macaw
 import Data.Macaw.Types (
   BVType,
   BoolType,
@@ -239,6 +239,9 @@ data FnValue (arch :: Type) (tp :: M.Type) where
   -- The int should be in the range @[0..argCount)@, and the type repr
   -- is the type of the argument.
   FnArg :: !Int -> !(TypeRepr tp) -> FnValue arch tp
+  FnCodePointer ::
+    Macaw.MemAddr (ArchAddrWidth arch) ->
+    FnValue arch (BVType (ArchAddrWidth arch))
 
 ------------------------------------------------------------------------
 -- FoldFnValue
@@ -260,12 +263,12 @@ class FoldFnValue (v :: Type -> Type) where
 type FnArchConstraints arch =
   ( IsArchFn (ArchFn arch)
   , IsArchStmt (FnArchStmt arch)
-  , MemWidth (ArchAddrWidth arch)
+  , Macaw.MemWidth (ArchAddrWidth arch)
   , HasRepr (ArchFn arch (FnValue arch)) TypeRepr
   , HasRepr (ArchReg arch) TypeRepr
   )
 
-instance MemWidth (ArchAddrWidth arch) => PP.Pretty (FnValue arch tp) where
+instance Macaw.MemWidth (ArchAddrWidth arch) => PP.Pretty (FnValue arch tp) where
   pretty (FnUndefined{}) = "undef"
   pretty (FnConstantBool b) = if b then "true" else "false"
   pretty (FnConstantValue w i)
@@ -276,6 +279,7 @@ instance MemWidth (ArchAddrWidth arch) => PP.Pretty (FnValue arch tp) where
   pretty (FnReturn var) = PP.pretty var
   pretty (FnFunctionEntryValue _ n) = PP.pretty (BSC.unpack n)
   pretty (FnArg i _) = "arg" <> PP.pretty i
+  pretty (FnCodePointer addr) = "codeptr" <> PP.pretty addr
 
 instance FnArchConstraints arch => PP.Pretty (FnAssignRhs arch (FnValue arch) tp) where
   pretty rhs =
@@ -289,7 +293,7 @@ instance FnArchConstraints arch => PP.Pretty (FnAssignRhs arch (FnValue arch) tp
         | i >= 0 ->
             PP.parens
               ( "0x" <> PP.pretty (showHex i "") <> " : " <> "bv"
-                  PP.<+> PP.pretty (8 * addrSize (Proxy :: Proxy (ArchAddrWidth arch)))
+                  PP.<+> PP.pretty (8 * Macaw.addrSize (Proxy :: Proxy (ArchAddrWidth arch)))
               )
         | otherwise -> error ("FnAddrWidthConstant given negative value: " ++ show i)
 
@@ -307,13 +311,13 @@ instance FnArchConstraints arch => ShowF (FnAssignment arch)
 
 archWidthTypeRepr ::
   forall p arch.
-  MemWidth (ArchAddrWidth arch) =>
+  Macaw.MemWidth (ArchAddrWidth arch) =>
   p arch ->
   TypeRepr (BVType (ArchAddrWidth arch))
-archWidthTypeRepr _ = BVTypeRepr (addrWidthNatRepr (addrWidthRepr (Proxy :: Proxy (ArchAddrWidth arch))))
+archWidthTypeRepr _ = BVTypeRepr (Macaw.addrWidthNatRepr (Macaw.addrWidthRepr (Proxy :: Proxy (ArchAddrWidth arch))))
 
 instance
-  (MemWidth (ArchAddrWidth arch), HasRepr (ArchFn arch f) TypeRepr) =>
+  (Macaw.MemWidth (ArchAddrWidth arch), HasRepr (ArchFn arch f) TypeRepr) =>
   HasRepr (FnAssignRhs arch f) TypeRepr
   where
   typeRepr rhs =
@@ -336,6 +340,7 @@ instance FnArchConstraints arch => HasRepr (FnValue arch) TypeRepr where
       FnReturn ret -> frReturnType ret
       FnFunctionEntryValue{} -> archWidthTypeRepr (Proxy :: Proxy arch)
       FnArg _ tp -> tp
+      FnCodePointer _ -> archWidthTypeRepr (Proxy :: Proxy arch)
 
 ------------------------------------------------------------------------
 -- FnStmt
@@ -406,20 +411,20 @@ instance FoldFnValue FnStmt where
 -- FnBlockLabel
 
 -- | A block label
-newtype FnBlockLabel w = FnBlockLabel {fnBlockLabelAddr :: MemSegmentOff w}
+newtype FnBlockLabel w = FnBlockLabel {fnBlockLabelAddr :: Macaw.MemSegmentOff w}
   deriving (Eq, Ord)
 
 -- | Render block label from segment offset.
-fnBlockLabelFromAddr :: MemSegmentOff w -> FnBlockLabel w
+fnBlockLabelFromAddr :: Macaw.MemSegmentOff w -> FnBlockLabel w
 fnBlockLabelFromAddr = FnBlockLabel
 
 instance PP.Pretty (FnBlockLabel w) where
   pretty (FnBlockLabel s) =
     let
-      a = segoffAddr s
-      o = memWordToUnsigned (addrOffset a)
+      a = Macaw.segoffAddr s
+      o = Macaw.memWordToUnsigned (Macaw.addrOffset a)
      in
-      "block_" <> PP.pretty (addrBase a) <> "_" <> PP.pretty (showHex o "")
+      "block_" <> PP.pretty (Macaw.addrBase a) <> "_" <> PP.pretty (showHex o "")
 
 -- | Render block label as a string
 fnBlockLabelString :: FnBlockLabel w -> String
@@ -439,7 +444,7 @@ data FnJumpTarget arch = FnJumpTarget
   -- These must match the type of the jump target.
   }
 
-instance MemWidth (ArchAddrWidth arch) => PP.Pretty (FnJumpTarget arch) where
+instance Macaw.MemWidth (ArchAddrWidth arch) => PP.Pretty (FnJumpTarget arch) where
   pretty tgt = PP.pretty (fnJumpLabel tgt) PP.<+> PP.encloseSep PP.lbracket PP.rbracket " " phiVals
    where
     phiVals = V.toList $ viewSome PP.pretty <$> fnJumpPhiValues tgt
@@ -514,7 +519,7 @@ data FnBlockInvariant arch where
   --
   -- @o@ is typically negative on processors whose stacks grow down.
   FnStackOff ::
-    !(MemInt (ArchAddrWidth arch)) ->
+    !(Macaw.MemInt (ArchAddrWidth arch)) ->
     !(BoundLoc (ArchReg arch) (BVType (ArchAddrWidth arch))) ->
     FnBlockInvariant arch
 
@@ -595,7 +600,7 @@ instance FoldFnValue FnBlock where
 -- This currently isn't the case, as Phi nodes still use `ArchReg` to index the
 -- nodes.  However, this will be changed.
 data Function arch = Function
-  { fnAddr :: !(MemSegmentOff (ArchAddrWidth arch))
+  { fnAddr :: !(Macaw.MemSegmentOff (ArchAddrWidth arch))
   -- ^ The address for this function
   , fnType :: !(FunctionType arch)
   -- ^ Type of this  function
@@ -641,7 +646,7 @@ instance
 
 -- | A function declaration that has type information, but no recovered definition.
 data FunctionDecl arch = FunctionDecl
-  { funDeclAddr :: !(MemSegmentOff (ArchAddrWidth arch))
+  { funDeclAddr :: !(Macaw.MemSegmentOff (ArchAddrWidth arch))
   -- ^ Address of function in binary.
   , funDeclName :: !BSC.ByteString
   -- ^ Symbol name for function.