dhscanner-bitcode 1.0.7 → 1.0.8

raw patch · 3 files changed

+131/−215 lines, 3 filesdep ~dhscanner-astPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: dhscanner-ast

API changes (from Hackage documentation)

Files

• dhscanner-bitcode.cabal +2/−2
• src/Bitcode.hs +55/−124
• src/Cfg.hs +74/−89

@@ -20,7 +20,7 @@     in mind. The commands resemble an abstract RISC-style assembley, motivated by keeping
     later-phases analyses as simple as possible.
 
-version:            1.0.7
+version:            1.0.8
 license:            GPL-3.0-only
 license-file:       LICENSE
 author:             OrenGitHub
@@ -48,7 +48,7 @@         aeson,
         base >=4.17 && <=4.20,
         containers,
-        dhscanner-ast >= 1.1.0,
+        dhscanner-ast >= 1.1.1,
 
     hs-source-dirs:
         src

@@ -46,12 +46,8 @@ import qualified Token
 
 -- general imports
-import Data.Aeson
 import GHC.Generics
-import Data.Set ( Set )
-
--- general (qualified) imports
-import qualified Data.Set
+import Data.Aeson ( ToJSON, FromJSON )
 
 -- |
 -- * All instructions have an associated location
@@ -76,10 +72,6 @@    | Assume AssumeContent
    | Return ReturnContent
    | Assign AssignContent
-   | LoadImmStr StrContent
-   | LoadImmInt IntContent
-   | LoadImmBool BoolContent
-   | LoadImmNull NullContent
    | ParamDecl ParamDeclContent
    | FieldRead FieldReadContent
    | FieldWrite FieldWriteContent
@@ -88,9 +80,18 @@    | SubscriptWrite SubscriptWriteContent
    deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
 
-mkNopInstruction :: Location -> Instruction
-mkNopInstruction l = Instruction { location = l, instructionContent = Nop }
+data Value
+   = VariableCtor Variable
+   | ConstValueCtor ConstValue
+   | KeywordArgCtor KeywordArgVariable
+   deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
 
+data Variable
+   = TmpVariableCtor TmpVariable
+   | SrcVariableCtor SrcVariable
+   | ParamVariableCtor ParamVariable
+   deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
+
 data TmpVariable
    = TmpVariable
      {
@@ -107,17 +108,6 @@      }
      deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
 
-data ArgContent
-   = ArgContent
-     {
-         argVariableFqn :: Fqn,
-         argVariableSerialIdx :: Word, -- ^ zero-based
-         -- location is indicative to the call
-         -- this arg was generated for
-         argVariableMyAwesomeCallContext :: Location
-     }
-     deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
-
 data ParamVariable
    = ParamVariable
      {
@@ -127,44 +117,41 @@      }
      deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
 
-data Variable
-   = TmpVariableCtor TmpVariable
-   | SrcVariableCtor SrcVariable
-   | ParamVariableCtor ParamVariable
-   | Arg ArgContent
-   deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
+data KeywordArgVariable
+   = KeywordArgVariable
+     {
+         keywordArgName :: String,
+         keywordArgValue :: Value
+     }
+     deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
 
 variableFqn :: Variable -> Fqn
 variableFqn (TmpVariableCtor   (TmpVariable   fqn _   )) = fqn
 variableFqn (SrcVariableCtor   (SrcVariable   fqn _   )) = fqn
 variableFqn (ParamVariableCtor (ParamVariable fqn _ _ )) = fqn
-variableFqn _ = Fqn "blah"
 
--- | Can /not/ be serialized to JSON
-data Variables = Variables { actualVariables :: Set Variable } deriving ( Show, Eq, Ord )
-
-data SrcVariables = SrcVariables { actualSrcVariables :: Set SrcVariable } deriving ( Show, Eq, Ord )
+locationVariable :: Variable -> Location
+locationVariable (TmpVariableCtor t) = tmpVariableLocation t
+locationVariable (SrcVariableCtor s) = Token.getVarNameLocation (srcVariableToken s)
+locationVariable (ParamVariableCtor p) = Token.getParamNameLocation (paramVariableToken p)
 
--- | Creating an empty collection of global variables
-createEmptyCollectionOfGlobalVariables :: SrcVariables
-createEmptyCollectionOfGlobalVariables = SrcVariables { actualSrcVariables = Data.Set.empty }
- 
--- | Can /not/ be serialized to JSON
-data TmpVariables = TmpVariables { actualTmpVariables :: Set TmpVariable } deriving ( Show, Eq, Ord )
+locationValue :: Value -> Location
+locationValue (VariableCtor v) = locationVariable v
+locationValue (ConstValueCtor c) = locationConstValue c
+locationValue (KeywordArgCtor k) = locationValue (keywordArgValue k)
 
-locationVariable :: Variable -> Location
-locationVariable v = case v of
-    (TmpVariableCtor tmpVariable) -> tmpVariableLocation tmpVariable
-    (SrcVariableCtor srcVariable) -> Token.getVarNameLocation $ srcVariableToken srcVariable
-    (ParamVariableCtor _paramVariable) -> Token.getParamNameLocation $ paramVariableToken _paramVariable
-    (Arg argContent) -> argVariableMyAwesomeCallContext argContent
+locationConstValue :: ConstValue -> Location
+locationConstValue (ConstIntValue  i) = Token.constIntLocation  i
+locationConstValue (ConstStrValue  s) = Token.constStrLocation  s
+locationConstValue (ConstBoolValue b) = Token.constBoolLocation b
+locationConstValue (ConstNullValue n) = Token.constNullLocation n
 
 data CallContent
    = CallContent
      {
          callOutput :: Variable,
          callee :: Variable,
-         args :: [ Variable ],
+         args :: [ Value ],
          callLocation :: Location
      }
      deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
@@ -182,8 +169,8 @@    = BinopContent
      {
          binopOutput :: Variable,
-         binopLhs :: Variable,
-         binopRhs :: Variable
+         binopLhs :: Value,
+         binopRhs :: Value
      }
      deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
 
@@ -191,25 +178,28 @@    = UnopContent
      {
          unopOutput :: Variable,
-         unopLhs :: Variable
+         unopLhs :: Value
      }
      deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
 
 data AssumeContent
    = AssumeContent
      {
-         assumeVariable :: Variable,
-         assumedValue :: Bool
+         assumeValue :: Value,
+         assumeTruthy :: Bool
      }
      deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
 
-mkAssumeInstruction :: Variable -> Bool -> Instruction
-mkAssumeInstruction v b = Instruction (locationVariable v) (Assume (AssumeContent v b))
+mkNopInstruction :: Location -> Instruction
+mkNopInstruction l = Instruction { location = l, instructionContent = Nop }
 
+mkAssumeInstruction :: Value -> Bool -> Instruction
+mkAssumeInstruction v b = Instruction (locationValue v) (Assume (AssumeContent v b))
+
 data ReturnContent
    = ReturnContent
      {
-         returnValue :: Maybe Variable
+         returnValue :: Maybe Value
      }
      deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
 
@@ -217,41 +207,16 @@    = AssignContent
      {
          assignOutput :: Variable,
-         assignInput :: Variable
-     }
-     deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
-
-data IntContent
-   = IntContent
-     {
-         loadImmIntOutput :: TmpVariable,
-         loadImmIntValue :: Token.ConstInt
-     }
-     deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
-
-data StrContent
-   = StrContent
-     {
-         loadImmStrOutput :: TmpVariable,
-         loadImmStrValue :: Token.ConstStr
-     }
-     deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
-
-data BoolContent
-   = BoolContent
-     {
-         loadImmBoolOutput :: TmpVariable,
-         loadImmBoolValue :: Token.ConstBool
+         assignInput :: Value
      }
      deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
 
-data NullContent
-   = NullContent
-     {
-         loadImmNullOutput :: TmpVariable,
-         loadImmNullValue :: Token.ConstNull
-     }
-     deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
+data ConstValue
+   = ConstIntValue Token.ConstInt
+   | ConstStrValue Token.ConstStr
+   | ConstBoolValue Token.ConstBool
+   | ConstNullValue Token.ConstNull
+   deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
 
 data FieldReadContent
    = FieldReadContent
@@ -267,7 +232,7 @@      {
          fieldWriteOutput :: Variable,
          fieldWriteName :: Token.FieldName,
-         fieldWriteInput :: Variable
+         fieldWriteInput :: Value
      }
      deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
 
@@ -276,7 +241,7 @@      {
          subscriptReadOutput :: Variable,
          subscriptReadInput :: Variable,
-         subscriptReadIdx :: Variable
+         subscriptReadIdx :: Value
      }
      deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
 
@@ -284,8 +249,8 @@    = SubscriptWriteContent
      {
          subscriptWriteOutput :: Variable,
-         subscriptWriteIdx :: Variable,
-         subscriptWriteInput :: Variable
+         subscriptWriteIdx :: Value,
+         subscriptWriteInput :: Value
      }
      deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
 
@@ -295,37 +260,3 @@          paramVariable :: ParamVariable
      }
      deriving ( Show, Eq, Generic, ToJSON, FromJSON, Ord )
-
-
--- |
---
--- * some instructions don't have an output variable
---
---     * 'Nop', 'Assume', 'Return' etc.
---
--- * other instructions have /exactly one/ output variable
---
-output :: InstructionContent -> Maybe Variable
-output (Unop          c) = Just $ unopOutput          c
-output (Call          c) = Just $ callOutput          c
-output (Binop         c) = Just $ binopOutput         c
-output (Assign        c) = Just $ assignOutput        c
-output (FieldRead     c) = Just $ fieldReadOutput     c
-output (SubscriptRead c) = Just $ subscriptReadOutput c
-output _              = Nothing
-
--- |
---
--- * some instructions don't have input variables /at all/
---
--- * other instructions have /multiple/ input variables
---
-inputs :: InstructionContent -> Set Variable
-inputs (Call       c) = Data.Set.fromList (args c)
-inputs              _ = Data.Set.empty
-
-variables :: InstructionContent -> Set Variable
-variables instruction = case output instruction of
-    Nothing -> inputs instruction
-    Just oneOutput -> (Data.Set.singleton oneOutput) `Data.Set.union` (inputs instruction)
-

@@ -7,114 +7,99 @@ where
 
 -- project imports
-import Location
 import qualified Bitcode
 
 -- general imports
 import Data.Aeson
 import GHC.Generics hiding ( from, to )
 import Prelude hiding ( filter, map )
-import Data.Set ( Set, fromList, filter, map, union )
-
-data Node
-   = Node
-     {
-         theInstructionInside :: Bitcode.Instruction
-     }
-     deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
+import Data.Set ( Set, fromList, map, union, empty, singleton )
 
-data Nodes
-   = Nodes
-     {
-         actualNodes :: Set Node
-     }
-     deriving ( Show, Eq, Ord )
+data Node = Node { theInstructionInside :: Bitcode.Instruction } deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
+data Nodes = Nodes { actualNodes :: Set Node } deriving ( Show, Eq, Ord )
 
-data Edge
-   = Edge
-     {
-         from :: Node,
-         to   :: Node
-     }
-     deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
+data Edge = Edge { from :: Node, to :: Node } deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
+data Edges = Edges { actualEdges :: Set Edge } deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
 
-data Edges
-   = Edges
-     {
-         actualEdges :: Set Edge
-     }
-     deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
+emptySetOfNodes :: Nodes
+emptySetOfNodes = Nodes { actualNodes = empty }
 
-mkEmptyCollectionOfEdges :: Edges
-mkEmptyCollectionOfEdges = Edges { actualEdges = fromList [] }
+emptySetOfEdges :: Edges
+emptySetOfEdges = Edges { actualEdges = empty }
 
-data Cfg
-   = Cfg
-     {
-         entry :: Node,
-         exit  :: Node,
-         edges :: Edges
-     }
-     deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
+data Cfg = Empty | Normal Content deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
 
-location :: Cfg -> Location
-location = Bitcode.location . theInstructionInside . entry
+data Content = Content { entry :: Node, exit  :: Node, edges :: Edges } deriving ( Show, Eq, Ord, Generic, ToJSON, FromJSON )
 
 nodes :: Cfg -> Nodes
-nodes g = Nodes { actualNodes = nodes' `union` nodes'' }
-    where
-        nodes'  = map from (actualEdges (edges g))
-        nodes'' = map to   (actualEdges (edges g))
+nodes Empty = emptySetOfNodes
+nodes (Normal cfg) = nodes' (edges cfg)
 
-preds :: Node -> Cfg -> Nodes
-preds node g = Nodes { actualNodes = map from edges' }
-    where
-        edges' = filter (\e -> (to e) == node) (actualEdges (edges g))    
+nodes' :: Edges -> Nodes
+nodes' = nodes'' . actualEdges
 
-empty :: Location -> Cfg
-empty _location = atom (Node (Bitcode.Instruction _location Bitcode.Nop))
+nodes'' :: Set Edge -> Nodes
+nodes'' edges' = Nodes { actualNodes = (map from edges') `union` (map to edges') }
 
 atom :: Node -> Cfg
-atom node = Cfg { entry = node, exit = node, edges = mkEmptyCollectionOfEdges }
+atom node = Normal (Content { entry = node, exit = node, edges = emptySetOfEdges })
 
 concat :: Cfg -> Cfg -> Cfg
-concat g1 g2 = Cfg { entry = entry g1, exit = exit g2, edges = edges' }
-    where
-        edges' = Edges $ edges1 `union` edges2 `union` connector
-            where
-                edges1 = actualEdges $ edges g1
-                edges2 = actualEdges $ edges g2
-                connector = fromList [Edge { from = exit g1, to = entry g2 }]
+concat Empty cfg = cfg
+concat (Normal content) cfg = Normal (concatNormalContentFirst content cfg)
 
-parallel :: Cfg -> Cfg -> Cfg
-parallel g1 g2 = Cfg { entry = s, exit = t, edges = edges' }
-    where
-        s = Node $ Bitcode.mkNopInstruction (Bitcode.location (theInstructionInside (entry g1)))
-        t = Node $ Bitcode.mkNopInstruction (Bitcode.location (theInstructionInside (exit  g2)))
-        edges' = Edges $ edges1 `union` edges2 `union` connectors
-            where
-                edges1 = actualEdges $ edges g1
-                edges2 = actualEdges $ edges g2
-                connectors = fromList [ s_g1, s_g2, g1_t, g2_t ]
-                    where
-                        s_g1 = Edge { from = s, to = entry g1 }
-                        s_g2 = Edge { from = s, to = entry g2 }
-                        g1_t = Edge { from = entry g1, to = t }
-                        g2_t = Edge { from = entry g2, to = t }
+concatNormalContentFirst :: Content -> Cfg -> Content
+concatNormalContentFirst content Empty = content
+concatNormalContentFirst cfg1 (Normal cfg2) = let
+    edges1 = actualEdges (edges cfg1)
+    edges2 = actualEdges (edges cfg2)
+    connector = singleton (Edge { from = exit cfg1, to = entry cfg2 })
+    edges12 = Edges (edges1 `union` edges2 `union` connector)
+    in Content { entry = entry cfg1, exit = exit cfg2, edges = edges12 }
 
--- | create a loop from condition and body
-loopify :: Cfg -> Cfg -> Bitcode.Variable -> Cfg
-loopify cond body guardedValue = Cfg { entry = entry cond, exit = t, edges = edges' }
-    where
-        t = Node $ Bitcode.mkNopInstruction (Bitcode.locationVariable guardedValue)
-        edges' = Edges $ edges1 `union` edges2 `union` connectors
-            where
-                edges1 = actualEdges $ edges cond
-                edges2 = actualEdges $ edges body
-                connectors = fromList [ e1, e2, e3, e4, e5 ]
-                    where
-                        e1 = Edge { from = exit cond, to = Node $ Bitcode.mkAssumeInstruction guardedValue True }
-                        e2 = Edge { from = exit cond, to = Node $ Bitcode.mkAssumeInstruction guardedValue False }
-                        e3 = Edge { from = Node $ Bitcode.mkAssumeInstruction guardedValue True, to = entry body }
-                        e4 = Edge { from = Node $ Bitcode.mkAssumeInstruction guardedValue False, to = t }
-                        e5 = Edge { from = exit body, to = entry cond }
+mkNopNode :: Node -> Node
+mkNopNode = Node . Bitcode.mkNopInstruction . Bitcode.location . theInstructionInside
+
+mkNewEntry :: Node -> Node
+mkNewEntry = mkNopNode
+
+mkNewExit :: Node -> Node
+mkNewExit = mkNopNode
+
+parallelNormalCfgs :: Content -> Content -> Cfg
+parallelNormalCfgs cfg1 cfg2 = let
+    s = mkNewEntry (entry cfg1)
+    t = mkNewExit (exit cfg2)
+    c1 = Edge { from = s, to = entry cfg1 }
+    c2 = Edge { from = s, to = entry cfg2 }
+    c3 = Edge { from = exit cfg1, to = t }
+    c4 = Edge { from = exit cfg2, to = t }
+    edges1 = actualEdges (edges cfg1)
+    edges2 = actualEdges (edges cfg2)
+    connectors = fromList [ c1, c2, c3, c4 ]
+    edges12 = Edges (edges1 `union` edges2 `union` connectors)
+    in Normal (Content { entry = s, exit = t, edges = edges12 })
+
+loopifyEmptyCondNormalBody :: Content -> Bitcode.Value -> Cfg
+loopifyEmptyCondNormalBody _body _guardedValue = Empty
+
+loopifyNormalCondEmptyBody :: Content -> Bitcode.Value -> Cfg
+loopifyNormalCondEmptyBody _cond _guardedValue = Empty
+
+loopify :: Cfg -> Cfg -> Bitcode.Value -> Cfg
+loopify Empty Empty _ = Empty
+loopify Empty (Normal body) guardedValue = loopifyEmptyCondNormalBody body guardedValue
+loopify (Normal cond) Empty guardedValue = loopifyNormalCondEmptyBody cond guardedValue
+loopify (Normal cond) (Normal body) guardedValue = let
+    guardedValueIsTrue = Node (Bitcode.mkAssumeInstruction guardedValue True)
+    guardedValueIsFalse = Node (Bitcode.mkAssumeInstruction guardedValue False)
+    c1 = Edge { from = exit cond, to = guardedValueIsTrue }
+    c2 = Edge { from = exit cond, to = guardedValueIsFalse }
+    c3 = Edge { from = guardedValueIsTrue, to = entry body }
+    c4 = Edge { from = guardedValueIsFalse, to = exit body }
+    c5 = Edge { from = exit body, to = entry cond }
+    edgesCond = actualEdges (edges cond)
+    edgesBody = actualEdges (edges body)
+    connectors = fromList [ c1, c2, c3, c4, c5 ]
+    edges' = Edges (edgesCond `union` edgesBody `union` connectors)
+    in Normal (Content { entry = entry cond, exit = exit body, edges = edges' })