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

scratch/stripped/function_pointer.c

@@ -0,0 +1,12 @@
+#include <stdlib.h>
+
+#include "function_pointer.h"
+
+// Trying to create a stripped object file, so we can attach a type to the
+// external symbol `apply` but not the other ones, via the C header.
+// int apply(int (*f)(int), int i) { return f(i); }
+
+int callee(int i) { return i; }
+int higher_order(int (*f)()) { return apply(f, 13); }
+int callit() { return higher_order(callee); }
+int main() { return 0; }

scratch/stripped/function_pointer.h

@@ -0,0 +1,10 @@
+#ifndef _FP_
+#define _FP_
+
+int apply(int (*f)(int), int);
+
+int callee();
+int higher_order(int (*f)(int));
+int callit();
+
+#endif // _FP_

scratch/stripped/main.c

@@ -0,0 +1,6 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+int main() {
+  return 0;
+}

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