|
| 1 | +{-# OPTIONS_GHC -Wwarn #-} |
| 2 | +{-# LANGUAGE OverloadedStrings #-} |
| 3 | +{-# LANGUAGE Strict #-} |
| 4 | +module Tokstyle.C.Linter.Memcpy (analyse) where |
| 5 | + |
| 6 | +import Control.Monad (unless) |
| 7 | +import Data.Functor.Identity (Identity) |
| 8 | +import Language.C.Analysis.AstAnalysis (ExprSide (..), tExpr) |
| 9 | +import Language.C.Analysis.SemError (typeMismatch) |
| 10 | +import Language.C.Analysis.SemRep (CompTypeRef (CompTypeRef), |
| 11 | + GlobalDecls, |
| 12 | + IntType (TyUChar), Type (..), |
| 13 | + TypeName (TyComp, TyIntegral, TyVoid)) |
| 14 | +import Language.C.Analysis.TravMonad (Trav, TravT, recordError) |
| 15 | +import Language.C.Analysis.TypeUtils (canonicalType) |
| 16 | +import Language.C.Data.Ident (Ident (..)) |
| 17 | +import Language.C.Pretty (pretty) |
| 18 | +import Language.C.Syntax.AST (CExpr, CExpression (..), |
| 19 | + annotation) |
| 20 | +import Tokstyle.C.Env (Env) |
| 21 | +import Tokstyle.C.TraverseAst (AstActions (..), astActions, |
| 22 | + traverseAst) |
| 23 | + |
| 24 | +compatibleType :: Type -> Type -> Bool |
| 25 | +compatibleType (PtrType a _ _ ) (PtrType b _ _ ) = compatibleType a b |
| 26 | +compatibleType (ArrayType a _ _ _) (PtrType b _ _ ) = compatibleType a b |
| 27 | +compatibleType (PtrType a _ _ ) (ArrayType b _ _ _) = compatibleType a b |
| 28 | +compatibleType (ArrayType a _ _ _) (ArrayType b _ _ _) = compatibleType a b |
| 29 | +compatibleType (DirectType a _ _ ) (DirectType b _ _ ) = compatibleTypeName a b |
| 30 | +compatibleType _ _ = False |
| 31 | + |
| 32 | +compatibleTypeName :: TypeName -> TypeName -> Bool |
| 33 | +-- `uint8_t*` can can be memcpy'd to and from any integral type. |
| 34 | +compatibleTypeName (TyIntegral TyUChar) TyIntegral{} = True |
| 35 | +compatibleTypeName TyIntegral{} (TyIntegral TyUChar) = True |
| 36 | +-- Integral types can only be memcpy'd to the same integral type. |
| 37 | +compatibleTypeName (TyIntegral a) (TyIntegral b) = a == b |
| 38 | +-- Structs can only be memcpy'd to the exact same struct. |
| 39 | +compatibleTypeName (TyComp (CompTypeRef a _ _)) (TyComp (CompTypeRef b _ _)) = a == b |
| 40 | +-- Everything else is disallowed. |
| 41 | +compatibleTypeName _ TyComp{} = False |
| 42 | +compatibleTypeName TyComp{} _ = False |
| 43 | +-- Void pointers are disallowed. |
| 44 | +compatibleTypeName TyVoid _ = False |
| 45 | +compatibleTypeName _ TyVoid = False |
| 46 | +-- Error here for now, to discover more cases. |
| 47 | +compatibleTypeName a b = error (show a ++ "\n" ++ show b) |
| 48 | + |
| 49 | +validMemType :: Type -> Bool |
| 50 | +validMemType (PtrType DirectType{} _ _ ) = True |
| 51 | +validMemType (ArrayType DirectType{} _ _ _) = True |
| 52 | +validMemType _ = False |
| 53 | + |
| 54 | +checkMemType :: String -> CExpr -> Type -> Trav Env () |
| 55 | +checkMemType fname expr ty = |
| 56 | + unless (validMemType (canonicalType ty)) $ |
| 57 | + let annot = (annotation expr, ty) in |
| 58 | + recordError $ typeMismatch |
| 59 | + ("`" <> fname <> "` argument type `" <> show (pretty ty) |
| 60 | + <> "` is not a valid memory type (pointers to arrays are not allowed)") |
| 61 | + annot annot |
| 62 | + |
| 63 | +checkCompatibility :: String -> CExpr -> CExpr -> Trav Env () |
| 64 | +checkCompatibility fname dst src = do |
| 65 | + dstTy <- tExpr [] RValue dst |
| 66 | + srcTy <- tExpr [] RValue src |
| 67 | + checkMemType fname dst dstTy |
| 68 | + checkMemType fname src srcTy |
| 69 | + unless (compatibleType (canonicalType dstTy) (canonicalType srcTy)) $ |
| 70 | + recordError $ typeMismatch |
| 71 | + ("`" <> fname <> "` first argument type `" <> show (pretty dstTy) |
| 72 | + <> "` is not compatible with second argument type `" |
| 73 | + <> show (pretty srcTy) <> "`") |
| 74 | + (annotation dst, dstTy) (annotation src, srcTy) |
| 75 | + |
| 76 | +linter :: AstActions (TravT Env Identity) |
| 77 | +linter = astActions |
| 78 | + { doExpr = \node act -> case node of |
| 79 | + CCall (CVar (Ident fname _ _) _) [dst, src, _] _ | fname `elem` ["memcpy", "memcmp"] -> do |
| 80 | + checkCompatibility fname dst src |
| 81 | + act |
| 82 | + |
| 83 | + _ -> act |
| 84 | + } |
| 85 | + |
| 86 | +analyse :: GlobalDecls -> Trav Env () |
| 87 | +analyse = traverseAst linter |
0 commit comments