Merge remote-tracking branch 'origin/master' into prod

c-examples/fwd.c

@@ -0,0 +1,6 @@
+
+typedef struct _A __CENTRINEL_MANAGED_ATTR A;
+
+void foo (A* a1, A* a2, unsigned long n);
+
+

src/Centrinel.hs

@@ -47,15 +47,18 @@ parseCFile cpp cppArgs = do
     inputStream <- withExceptT CentCPPError $ ExceptT $ CPP.runPreprocessor cpp cppArgs
     withExceptT CentParseError $ ExceptT $ return $ parseC inputStream (initPos $ CPP.inputFile cppArgs)
 
-getInferredRegions :: A.GlobalDecls -> HG.HGTrav s RegionInferenceResult
-getInferredRegions g = do
-  let structDefs = HG.justStructTagDefs (A.gTags g)
-  makeRegionInferenceResult <$> traverse HG.applyBindingTagDef structDefs
-
+getInferredStructTagRegions :: HG.HGTrav s RegionInferenceResult
+getInferredStructTagRegions = makeRegionInferenceResult <$> HG.frozenRegionUnificationState
+
+-- | Run the "language-c" semantic analysis pass on the given C translation unit and simultaneously
+-- apply the region unification algorithm to all structs with a region attribute.
+--
+-- Return the global declarations from the semantic analysis and a mapping from
+-- struct tags to their inferred region schemes.
 inferRegions :: CTranslUnit -> HG.HGTrav s (A.GlobalDecls, RegionInferenceResult)
 inferRegions u = do
   g <- HG.withHGAnalysis (nonFatal . HG.inferDeclEvent) $ A.analyseAST u
-  regions <- getInferredRegions g
+  regions <- getInferredStructTagRegions
   return (g, regions)
 
 -- | Catch any errors due to the given computation, record them as warnings and continue.

src/Centrinel/NakedPointerError.hs

@@ -74,9 +74,9 @@ mkNakedPointerError :: Bool -> C.NodeInfo -> [NPEVictim] -> NakedPointerError
 mkNakedPointerError inDefn ni npes = NakedPointerError inDefn ni npes Err.LevelWarn
 
 instance Err.Error NakedPointerError where
-  errorInfo (NakedPointerError inDefn ni victims lvl) = Err.mkErrorInfo lvl msg ni
+  errorInfo (NakedPointerError inDefn ni vs lvl) = Err.mkErrorInfo lvl msg ni
     where
-      msg = PP.render $ PP.vcat (msghead : map PP.pretty victims)
+      msg = PP.render $ PP.vcat (msghead : map PP.pretty vs)
       msghead = PP.text ("Naked pointer(s) to managed object(s) found in "
                          <> if inDefn then "definition" else "declaration")
   changeErrorLevel npe lvl =

src/Centrinel/RegionInference.hs

@@ -1,9 +1,8 @@
 -- | Analyze a parsed C file and create region unification constraints
 --
 {-# LANGUAGE FunctionalDependencies #-}
-module Centrinel.RegionInference (inferDeclEvent, hasRegionAttr, applyBindingTagDef, justStructTagDefs) where
+module Centrinel.RegionInference (inferDeclEvent, hasRegionAttr) where
 
-import qualified Data.Map
 import Data.Monoid (First(..))
 
 -- data
@@ -17,11 +16,8 @@ import qualified Language.C.Syntax.Constants as Syn
 -- semantics
 import qualified Language.C.Analysis.SemRep as A
 
-import Language.C.Analysis.Debug () -- P.Pretty instances 
-
 import Centrinel.Region.Region
 import Centrinel.Region.Unification
-import Centrinel.Region.Unification.Term (regionUnifyVar, RegionVar)
 import Centrinel.Region.Ident
 
 inferDeclEvent :: (RegionAssignment RegionIdent v m, RegionUnification v m) => A.DeclEvent -> m ()
@@ -32,27 +28,35 @@ inferDeclEvent e =
       -- then try to unify with region from the first member.  That way we have
       -- both if unification fails.
       r <- assignRegion (StructTagId suref)
-      case hasRegionAttr attrs of
-        Just rc -> do
-          constantRegion r rc
-          regionAddLocation r ni
-        Nothing -> return ()
+      unifyWithAttrs r attrs ni
       m <- deriveRegionFromMember structTy
       case m of
         Just r' -> sameRegion r' r
         Nothing -> return ()
-    A.TypeDefEvent (A.TypeDef typedefIdent ty _ _) -> do
+    A.TypeDefEvent (A.TypeDef typedefIdent ty attrs ni) -> do
       m <- deriveRegionFromType ty
       r <- assignRegion (TypedefId typedefIdent)
+      unifyWithAttrs r attrs ni
       case m of
         Just r' -> sameRegion r' r
         Nothing -> return ()
     _ -> return ()
 
+-- | @unifyWithAttrs r attr ni@ unifies the region @r@ with any regions attributes found among @attr@
+-- and adds the location of @ni@ to the occurrences of @r@.
+unifyWithAttrs :: (C.CNode n, RegionUnification v m) => v -> A.Attributes -> n -> m ()
+unifyWithAttrs r attrs ni =
+  case hasRegionAttr attrs of
+    Just rc -> do
+      constantRegion r rc
+      regionAddLocation r ni
+    Nothing -> return ()
+
 hasRegionAttr :: A.Attributes -> Maybe Region
 hasRegionAttr = getFirst . foldMap (First . from)
   where
-    from (A.Attr ident [Syn.CConst (Syn.CIntConst r _)] _ni) | Id.identToString ident == "__region" = Just (Region $ fromInteger $ Syn.getCInteger r)
+    from (A.Attr ident [Syn.CConst (Syn.CIntConst r _)] _ni) | Id.identToString ident == "__region" =
+                                                               Just (Region $ fromInteger $ Syn.getCInteger r)
     from _ = Nothing
 
 withLocation :: (RegionUnification v m, C.CNode n) => n -> Maybe v -> m (Maybe v)
@@ -68,7 +72,11 @@ deriveRegionFromMember (A.CompType _suref A.StructTag (A.MemberDecl (A.VarDecl _
 deriveRegionFromMember _ = return Nothing
 
 deriveRegionFromType :: (RegionAssignment RegionIdent v m, RegionUnification v m) => A.Type -> m (Maybe v)
-deriveRegionFromType (A.DirectType t _qs _attrs) = deriveRegionFromTypeName t
+deriveRegionFromType (A.DirectType t _qs _attrs) =
+  -- the _attrs here don't seem to work when, for example, we have
+  --   typedef struct __attribute__((...)) TagName TypeDefName;
+  -- (not clear if that's to be expected, or a language-c bug).
+  deriveRegionFromTypeName t
 deriveRegionFromType (A.TypeDefType td _qs _attrs) = deriveRegionFromTypeDefRef td
 deriveRegionFromType _ = return Nothing
 
@@ -82,16 +90,3 @@ deriveRegionFromTypeDefRef (A.TypeDefRef _ t _ni) = deriveRegionFromType t
 deriveRegionFromSUERef :: (RegionAssignment RegionIdent v m) => Id.SUERef -> m v
 deriveRegionFromSUERef suref = assignRegion (StructTagId suref)
 
--- Apply the current unification bindings to a given struct definition and return the inferred region.
-applyBindingTagDef :: (ApplyUnificationState m, RegionAssignment RegionIdent RegionVar m) => A.TagDef -> m RegionScheme
-applyBindingTagDef (A.CompDef (A.CompType sueref A.StructTag _members _attrs _ni)) = do
-  v <- assignRegion (StructTagId sueref)
-  m <- applyUnificationState (regionUnifyVar v)
-  return $ extractRegionScheme m
-applyBindingTagDef _ = return PolyRS
-
-justStructTagDefs :: Data.Map.Map k A.TagDef -> Data.Map.Map k A.TagDef
-justStructTagDefs = Data.Map.filter isStruct
-  where
-    isStruct (A.CompDef (A.CompType _sueref A.StructTag _membs _attrs _ni)) = True
-    isStruct _ = False

src/Centrinel/Report/Json.hs

@@ -17,7 +17,7 @@ import qualified System.IO as IO
 import Language.C.Parser (ParseError)
 import Language.C.Data.Error (CError)
 import qualified Language.C.Data.Error as CError
-import Centrinel.RegionMismatchError (RegionMismatchError(..))
+import Centrinel.RegionMismatchError (RegionMismatchError)
 import Centrinel.NakedPointerError (NakedPointerError)
 
 import qualified Centrinel.Report.Types as R
@@ -80,18 +80,19 @@ encodeCentrinelAnalysisMessage e = encodeErrorInfo (errorInfo e) <> encodeSpecif
       errorInfo (CErrorMessage m) = CError.errorInfo m
 
 encodeErrorInfo :: Data.Aeson.KeyValue kv => CError.ErrorInfo -> [kv]
-encodeErrorInfo (CError.ErrorInfo errorLevel position lines) =
+encodeErrorInfo (CError.ErrorInfo errorLevel position msgLines) =
   [ "errorLevel" .= (show errorLevel)
   , "position" .= (show position)
-  , "lines" .= lines
+  , "lines" .= msgLines
   ]
 
+ea :: Data.Aeson.Value
 ea = Data.Aeson.Array mempty
 
 encodeSpecificMessage :: Data.Aeson.KeyValue kv => CentrinelAnalysisMessage -> [kv]
-encodeSpecificMessage (RegionMismatchMessage rme) = tag "regionMismatchMessage" <> ["regionMismatchMessage" .= ea] -- [vic1, vic2]
-encodeSpecificMessage (NakedPointerMessage npe) = tag "nakedPointerMessage" <> ["nakedPointerMessage" .= ea]
-encodeSpecificMessage (CErrorMessage npe) = []
+encodeSpecificMessage (RegionMismatchMessage _rme) = tag "regionMismatchMessage" <> ["regionMismatchMessage" .= ea] -- [vic1, vic2]
+encodeSpecificMessage (NakedPointerMessage _npe) = tag "nakedPointerMessage" <> ["nakedPointerMessage" .= ea]
+encodeSpecificMessage (CErrorMessage _npe) = []
 
 instance Data.Aeson.ToJSON ToolFail where
   toJSON tf = Data.Aeson.object (encodeToolFail tf)
@@ -105,12 +106,22 @@ output :: Bool -> IO.Handle -> FilePath -> FilePath -> R.Message -> IO ()
 output _isFile h = \workDir fp rmsg ->
   case rmsg of
     R.Normal warns ->
-      unless (null warns) $ put $ TranslationUnitMessage workDir fp $ NormalMessages False $ map massageError warns
+      unless (null warns) $ put $ TranslationUnitMessage
+      { workingDirectory = workDir
+      , translationUnit = fp
+      , message = NormalMessages
+        { isAbnormal = False
+        , messages = map massageError warns
+        }
+      }
     R.Abnormal centErr ->
       put $ TranslationUnitMessage workDir fp $ case centErr of
-        R.CentCPPError exitCode -> ToolFailMessage $ CPPToolFail exitCode
-        R.CentParseError err -> ToolFailMessage $ ParseToolFail err
-        R.CentAbortedAnalysisError errs -> NormalMessages True $ map massageError errs
+        R.CentCPPError exitCode -> ToolFailMessage { toolFailure = CPPToolFail exitCode }
+        R.CentParseError err -> ToolFailMessage { toolFailure = ParseToolFail err }
+        R.CentAbortedAnalysisError errs -> NormalMessages
+          { isAbnormal = True
+          , messages = map massageError errs
+          }
   where
     put msg = do
       BS.hPut h (Data.Aeson.encode msg)

src/Centrinel/Trav.hs

@@ -13,6 +13,7 @@ module Centrinel.Trav (
   , HGAnalysis
   , withHGAnalysis
   , RegionIdentMap
+  , frozenRegionUnificationState
   ) where
 
 import Control.Monad.Trans.Class 
@@ -23,15 +24,17 @@ import Control.Monad.Trans.State.Lazy (StateT)
 import qualified Control.Monad.Trans.State.Lazy as State
 
 import Data.Bifunctor (Bifunctor(..))
-import qualified Data.Map as Map
+import qualified Data.Map.Lazy as Map
 
+import Language.C.Data.Ident (SUERef)
 import Language.C.Data.Error (CError, fromError)
 
 import Language.C.Analysis.SemRep (DeclEvent)
 import qualified Language.C.Analysis.TravMonad as AM
 import Language.C.Analysis.TravMonad.Instances ()
 
 import qualified Centrinel.Region.Ident as HGId
+import Centrinel.Region.Region (RegionScheme)
 import qualified Centrinel.Region.Unification as U
 import qualified Centrinel.Region.Unification.Term as U
 import Centrinel.Types (CentrinelAnalysisError (..))
@@ -82,6 +85,23 @@ getRegionIdent i = HGTrav $ lift $ State.gets (Map.lookup i)
 putRegionIdent :: HGId.RegionIdent -> U.RegionUnifyTerm -> HGTrav s ()
 putRegionIdent i m = HGTrav $ lift $ State.modify' (Map.insert i m)
 
+-- | Gets a mapping of the region identifiers that have been noted by
+-- unification to their 'RegionScheme' as implied by the constraints available
+-- at the time of the call.
+frozenRegionUnificationState :: HGTrav s (Map.Map SUERef RegionScheme)
+frozenRegionUnificationState = do
+  sueRegions <- HGTrav $ lift $ State.gets munge
+  traverse (fmap U.extractRegionScheme . U.applyUnificationState) sueRegions
+  where
+    munge :: Map.Map HGId.RegionIdent U.RegionUnifyTerm -> Map.Map SUERef U.RegionUnifyTerm
+    munge = Map.mapKeysMonotonic onlySUERef . Map.filterWithKey (\k -> const (isStructTag k))
+    onlySUERef :: HGId.RegionIdent -> SUERef
+    onlySUERef (HGId.StructTagId sue) = sue
+    onlySUERef (HGId.TypedefId {}) = error "unexpected TypedefId in onlySUERef"
+    isStructTag :: HGId.RegionIdent -> Bool
+    isStructTag (HGId.StructTagId {}) = True
+    isStructTag (HGId.TypedefId {}) = False
+
 instance HGId.RegionAssignment HGId.RegionIdent U.RegionVar (HGTrav s) where
   assignRegion i = do
     v <- U.newRegion

src/Centrinel/Util/CompilationDatabase.hs

@@ -7,7 +7,6 @@ module Centrinel.Util.CompilationDatabase (parseCompilationDatabase
                                           , combineDuplicateRuns
                                           , divideRunLikeCC) where
 
-import Data.Function (on)
 import Data.Monoid (Monoid(..), (<>))
 import Data.Text (Text)
 import qualified Data.Map.Lazy as M