[#33] Added dead arcs to graph

Also used the chance to remove the compound arcs

core/src/Ohua/DFGraph.hs

@@ -11,6 +11,7 @@ module Ohua.DFGraph where
 import Ohua.Prelude
 
 import qualified Data.HashMap.Strict as HM
+import qualified Data.HashSet as HS
 import Ohua.DFLang.Lang
 
 data Operator = Operator
@@ -26,20 +27,22 @@ data Target = Target
 
 data Arcs envExpr = Arcs
     { direct :: ![DirectArc envExpr]
-    , compound :: ![CompoundArc]
     , state :: ![StateArc envExpr]
+    , dead :: ![DeadArc]
     } deriving (Eq, Generic, Show)
 
 data Arc target source = Arc
     { target :: !target
     , source :: !source
     } deriving (Eq, Show, Generic)
 
-type CompoundArc = Arc Target [Target]
-
 type DirectArc envExpr = Arc Target (Source envExpr)
-
 type StateArc envExpr = Arc FnId (Source envExpr)
+-- | A dead arc is a binding created in DFLang that is unused. Hence its
+-- 'target' field is the constant '()' and the 'source' is some operator at some
+-- index. Mostly this is used when dataflow operators that implement the
+-- argument dispatch themselves have one of their outputs be unused.
+type DeadArc = Arc () Target
 
 data Source envExpr
     = LocalSource !Target
@@ -94,17 +97,12 @@ toGraph (DFExpr lets r) = OutGraph ops grArcs (getSource r)
             | (var, idx) <- zip (output l) [0 ..]
             ]
     grArcs =
-        let (compounds, directs) =
-                partitionEithers
-                    [ case v of
-                        DFVarList l -> Left $ arc $ map getSource l
-                        _ -> Right $ arc $ varToSource v
-                    | LetExpr {..} <- toList lets
-                    , (idx, v) <- zip [0 ..] callArguments
-                    , let arc :: source -> Arc Target source
-                          arc = Arc $ Target callSiteId idx
-                    ]
-         in Arcs directs compounds states
+        let directs =
+                [ Arc (Target callSiteId idx) $ varToSource v
+                | LetExpr {..} <- toList lets
+                , (idx, v) <- zip [0 ..] callArguments
+                ]
+         in Arcs directs states deads
     getSource v =
         fromMaybe
             (error $
@@ -115,6 +113,12 @@ toGraph (DFExpr lets r) = OutGraph ops grArcs (getSource r)
         \case
             DFVar v -> LocalSource $ getSource v
             DFEnvVar envExpr -> EnvSource envExpr
-            DFVarList _ -> error "Invariant Broken!"
+    deads =
+        map (Arc () . getSource) $
+        HS.toList $ allBindings `HS.difference` usedBindings
+      where
+        allBindings = HS.fromList $ toList lets >>= output
+        usedBindings =
+            HS.fromList $ [v | l <- toList lets, DFVar v <- callArguments l]
 -- spliceEnv :: (Int -> a) -> OutGraph -> AbstractOutGraph a
 -- spliceEnv lookupExpr = fmap f where f i = lookupExpr $ unwrap i

core/src/Ohua/DFGraph/Show.hs

@@ -15,7 +15,7 @@ import Ohua.DFGraph
 
 -- | TODO show return arc
 asTable :: OutGraph -> T.Text
-asTable (OutGraph ops (Arcs direct compound state) _) =
+asTable (OutGraph ops Arcs {..} _) =
     T.pack $
     render $
     vsep
@@ -28,20 +28,15 @@ asTable (OutGraph ops (Arcs direct compound state) _) =
               4
               top
               [sourceList direct sourceToBox, targetList direct targetToBox]
-        , text "Compound Arcs"
-        , hsep
-              4
-              top
-              [ sourceList compound $ hsep 1 left . map targetToBox
-              , targetList compound targetToBox
-              ]
         , text "State Arcs"
         , hsep
               4
               top
               [ sourceList state sourceToBox
               , targetList state $ text . show . unwrap
               ]
+        , text "Dead Arcs"
+        , hsep 4 top [sourceList dead $ targetToBox]
         ]
   where
     idList =

core/src/Ohua/DFLang/Lang.hs

@@ -52,7 +52,7 @@ data DFFnRef = DFFnRef
 instance Hashable DFFnRef
 
 pattern DFFunction :: QualifiedBinding -> DFFnRef
-pattern DFFunction b = DFFnRef OperatorNode b 
+pattern DFFunction b = DFFnRef OperatorNode b
 
 pattern EmbedSf :: QualifiedBinding -> DFFnRef
 pattern EmbedSf b = DFFnRef FunctionNode b
@@ -71,7 +71,6 @@ instance NFData NodeType
 data DFVar
     = DFEnvVar !Lit
     | DFVar !Binding
-    | DFVarList ![Binding]
     deriving (Eq, Show, Lift, Generic)
 
 instance Hashable DFVar

core/src/Ohua/DFLang/PPrint.hs

@@ -34,7 +34,6 @@ prettyDFVar :: DFVar -> Doc a
 prettyDFVar = \case
     DFEnvVar he -> pretty he
     DFVar b -> pretty b
-    DFVarList bnds -> PP.list $ map pretty bnds
 
 instance Pretty DFVar where
     pretty = prettyDFVar

core/src/Ohua/DFLang/Passes.hs

@@ -29,7 +29,6 @@ import Ohua.ALang.PPrint
 
 import Ohua.DFLang.Lang
 import qualified Ohua.DFLang.Refs as Refs
-import Ohua.DFLang.Util
 import Ohua.Stage
 
 type Pass m
@@ -209,8 +208,7 @@ collapseNth selectionFunction =
             return $
                 Just
                     e {output = newOuts, functionRef = DFFnRef OperatorNode fun}
-        | [DFEnvVar (NumericLit index), _len, DFVar source] <- callArguments e = do
-            toRemove <- getPast
+        | [DFEnvVar (NumericLit index), _len, DFVar source] <- callArguments e =
             ifM
                 (queryRemoval source)
                 (recordRemoval source oldOut index >> return Nothing)

core/src/Ohua/DFLang/Verify.hs

@@ -18,22 +18,6 @@ verify = sequence_ . sequenceA checks
     checks :: [DFExpr -> m ()]
     checks = [checkBuiltinArities]
 
-checkDFVarList :: MonadError Error m => DFExpr -> m ()
-checkDFVarList e = for_ (letExprs e) check
-  where
-    check l@(LetExpr {functionRef, callArguments})
-        | hasVarArgList callArguments =
-            case functionRef of
-                DFFunction _ -> pure ()
-                _ ->
-                    error $
-                    "Invariant broken: Only dataflow operators can have var lists! " <>
-                    "This is not a dataflow function: " <>
-                    (show l)
-    hasVarArgList (DFVarList _:_) = True
-    hasVarArgList (_:[]) = False
-    hasVarArgList (_:args) = hasVarArgList args
-
 checkBuiltinArities :: MonadError Error m => DFExpr -> m ()
 checkBuiltinArities e =
     for_ (letExprs e) $ \LetExpr {functionRef, callArguments} ->

core/src/Ohua/Feature/TailRec/Passes/DFLang.hs

@@ -8,8 +8,7 @@ import Ohua.DFLang.Refs as Refs
 import Ohua.DFLang.Util
 import qualified Ohua.Feature.TailRec.Passes.ALang as ALangPass
 
-import qualified Data.List.NonEmpty as NE
-import Data.Sequence as DS ((><), filter)
+import Data.Sequence as DS (filter)
 
 recurLowering :: DFExpr -> DFExpr
 recurLowering (DFExpr letExprs returnVar)

tests/src/AesonConvertSpec.hs

@@ -55,7 +55,7 @@ spec = describe "encode . decode == id" $ do
     prop "for targets" (testConvert :: Target -> Result)
     prop "for direct arcs" (testConvert :: DirectArc Lit -> Result)
     prop "for state arcs" (testConvert :: StateArc Lit -> Result)
-    prop "for compound arcs" (testConvert :: CompoundArc -> Result)
+    prop "for compound arcs" (testConvert :: DeadArc -> Result)
     prop "for sources" (testConvert :: Source HostExpr -> Result)
     prop "for fn names" (testConvert :: Binding -> Result)
     prop "for fn ids" (testConvert :: FnId -> Result)