From e74e074e62a647beb6b8ba8aae531b4c30704f06 Mon Sep 17 00:00:00 2001 From: Aleksey Kliger Date: Thu, 9 Nov 2017 16:23:49 -0500 Subject: [PATCH 1/2] [RegionInference] Pick up regions of structs that do not have defns If a header defines `SomeTypeDefName` but never gives a definition for `struct SomeTag`, below, we should still warn about occurrences of `SomeTypeDefName *`. ``` typedef struct SomeTag __attribute__((region(k))) SomeTypeDefName; ``` Closes #17 --- c-examples/fwd.c | 6 ++++ src/Centrinel.hs | 15 ++++++---- src/Centrinel/RegionInference.hs | 47 ++++++++++++++------------------ src/Centrinel/Trav.hs | 22 ++++++++++++++- 4 files changed, 57 insertions(+), 33 deletions(-) create mode 100644 c-examples/fwd.c diff --git a/c-examples/fwd.c b/c-examples/fwd.c new file mode 100644 index 0000000..a5dfd8d --- /dev/null +++ b/c-examples/fwd.c @@ -0,0 +1,6 @@ + +typedef struct _A __CENTRINEL_MANAGED_ATTR A; + +void foo (A* a1, A* a2, unsigned long n); + + diff --git a/src/Centrinel.hs b/src/Centrinel.hs index e660328..8813c2c 100644 --- a/src/Centrinel.hs +++ b/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. diff --git a/src/Centrinel/RegionInference.hs b/src/Centrinel/RegionInference.hs index 51a62a9..f19e6c4 100644 --- a/src/Centrinel/RegionInference.hs +++ b/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 diff --git a/src/Centrinel/Trav.hs b/src/Centrinel/Trav.hs index 3bd64e5..cfcbaf6 100644 --- a/src/Centrinel/Trav.hs +++ b/src/Centrinel/Trav.hs @@ -13,6 +13,7 @@ module Centrinel.Trav ( , HGAnalysis , withHGAnalysis , RegionIdentMap + , frozenRegionUnificationState ) where import Control.Monad.Trans.Class @@ -23,8 +24,9 @@ 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) @@ -32,6 +34,7 @@ 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 From 1dee4080fd0137dddf4408b8c876fc1313d2e42d Mon Sep 17 00:00:00 2001 From: Aleksey Kliger Date: Thu, 9 Nov 2017 16:50:18 -0500 Subject: [PATCH 2/2] Cleanup warnings (NFC) --- src/Centrinel/NakedPointerError.hs | 4 +-- src/Centrinel/Report/Json.hs | 31 +++++++++++++++-------- src/Centrinel/Util/CompilationDatabase.hs | 1 - 3 files changed, 23 insertions(+), 13 deletions(-) diff --git a/src/Centrinel/NakedPointerError.hs b/src/Centrinel/NakedPointerError.hs index 00ce1d3..62287d2 100644 --- a/src/Centrinel/NakedPointerError.hs +++ b/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 = diff --git a/src/Centrinel/Report/Json.hs b/src/Centrinel/Report/Json.hs index 342518a..89cf138 100644 --- a/src/Centrinel/Report/Json.hs +++ b/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) diff --git a/src/Centrinel/Util/CompilationDatabase.hs b/src/Centrinel/Util/CompilationDatabase.hs index 6ee5d2b..5c11357 100644 --- a/src/Centrinel/Util/CompilationDatabase.hs +++ b/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