haskell - Hoopl：图构建和不可达块的自动删除

Question

我正在使用 Hoopl 库开展一个项目，但我遇到了一个障碍，这表明我并不完全了解引擎盖下发生了什么。简而言之，Hoopl 似乎认为我的图表中的某些块无法到达（IMO）它不应该。我正在实现一个稀疏的条件常数传播，所以我确实希望某些块变得无法访问，但不是所有块！下面是一个示例，取自我用来制作原型的 HUnit 测试套件。该示例使用了几个未在此处定义的函数，但我为那些确认它们独立工作的单独的单元测试，特别是fromHoopl . toHoopl x按预期工作的函数，等等。

我期望发生的是这block_cprop_out应该是运行这个 pass 的结果，但实际结果只是 const 折叠版本block_cprop_in_0：true 和 false 分支都被消除了。HUnit 测试的输出位于代码片段下方。

为了概括我在高层次上所做的事情，我为每个块创建了一个封闭/封闭的 Hoopl 图，然后将这些图与Hoopl.|*><*|. 我使用一个简单Data.Map的方法来跟踪 Hoopl 为用户标签分配的唯一标签，这样，当我重写 a 时Branch userlabel，我可以将 Hoopl 后继标签修改为正确的 Hoopl Label。然而，Hoopl 似乎认为真假分支块在这里都不可达，因为在我运行这个前向分析和重写之后，我得到一个只包含入口块的图。

block_cprop_out这里有点奇怪，因为我的fromHoopl函数只是调用Hoopl.foldGraphNodes将整个 HooplGraph a变成一个简单[a]的检查。

一个单独的测试证实，使用相同的图形构造方法（连接封闭/封闭块）来往返这个块列表可以按预期工作；似乎消除无法访问的块是由Hoopl.analyzeAndRewrite{Fwd,Bwd}.

像我在这里做的那样拼接一个封闭/封闭块的列表是否正确？如果是这样，任何人都可以在这里看到任何可能导致 Hoopl 认为区块无法访问的可疑内容吗？

block_cprop_in_0 = [ --test for constprop
                     L $ Label "entry",
                     O $ Sub (Reg "r0") (Reg "r0"),
                     T $ CondBranch (Reg "r0") (Label "tb") (Label "fb")
                   ]

block_cprop_in_1 = [ -- test for constprop
                     L $ Label "tb",
                     O $ Sub (Reg "r1") (Reg "r0"),
                     T $ Halt
                   ] -- this block is unreachable from the CondBranch in block_cprop_in_0

block_cprop_in_2 = [ -- test for constprop
                     L $ Label "fb",
                     O $ Sub (Reg "r2") (Reg "r0"), --should get rewritten as a SubI
                     T $ Halt
                   ]

block_cprop_out = [ --test for constprop
                    L $ Label "entry",
                    O $ Sub (Reg "r0") (Reg "r0"),
                    T $ Branch (Label "fb"),
                    L $ Label "fb",
                    O $ SubI 0 (Reg "r2"),
                    T $ Halt
                  ]

test_hoopl_6 =
  let p = [block_cprop_in_0, block_cprop_in_1, block_cprop_in_2]
      p' :: (H.Graph (Node Instruction) H.C H.C) = H.runSimpleUniqueMonad $ H.runWithFuel H.infiniteFuel $ (transform p :: H.SimpleFuelMonad (H.Graph (Node Instruction) H.C H.C))
      unP' :: [Instruction] = fromHoopl p'
  in unP' @?= block_cprop_out
  where
    transform :: (H.CheckpointMonad m, H.FuelMonad m, H.UniqueMonad m) => [[Instruction]] -> m (H.Graph (Node Instruction) H.C H.C)
    transform prog = do
      (hlms, ps) <- liftM unzip $ forM prog toHoopl
      let hlm = Map.unions hlms
      let p = foldl (H.|*><*|) H.emptyClosedGraph ps
      let hooplLabelFor = fromJust . flip Map.lookup hlm
      let eLabel = hooplLabelFor $ Label "entry"
      let registers = ["r0", "r1", "r2", "r3"]
      p' <- runConstProp registers hooplLabelFor eLabel p
      return p'

    constLattice :: H.DataflowLattice ConstFact
    constLattice = H.DataflowLattice
     { H.fact_name = "Register Contents"
     , H.fact_bot  = Map.empty
     , H.fact_join = H.joinMaps (H.extendJoinDomain constFactAdd)
     }
     where
       constFactAdd _ (H.OldFact old) (H.NewFact new)
           = if new == old then (H.NoChange, H.PElem new)
             else               (H.SomeChange, H.Top)

    -- initially all registers have unknown contents
    initFact :: [Register] -> ConstFact
    initFact regs = Map.fromList $ [(r, H.Top) | r <- regs]

    -- transfer function: register value is a constant
    regIsConstant :: (Label -> H.Label) -> H.FwdTransfer (Node Instruction) ConstFact
    regIsConstant hooplLabelFor = H.mkFTransfer rc
     where
      rc :: Node Instruction e x -> ConstFact -> H.Fact x ConstFact
      rc (NodeInit _ _) f = f

      -- subtracting a register from itself yields zero
      rc (NodeCont (O (Sub (Reg a) (Reg b)))) f
        = if a == b then Map.insert a (H.PElem 0) f else f

      rc (NodeCont (O (Sub _ (Reg x)))) f   = Map.insert x H.Top f
      rc (NodeCont (O (SubI _ (Reg x)))) f  = Map.insert x H.Top f
      rc (NodeCont (O (SubM _ (Reg x)))) f  = Map.insert x H.Top f
      rc (NodeCont (O (Load _ (Reg x)))) f  = Map.insert x H.Top f
      rc (NodeCont (O (Store _ (Reg x)))) f = Map.insert x H.Top f
      rc (NodeCont (O (CmpEq _ (Reg x)))) f = Map.insert x H.Top f
      rc (NodeCont (O (CmpLt _ (Reg x)))) f = Map.insert x H.Top f
      rc (NodeCont (O _)) f = f

      rc (NodeTerm (T Halt) _) f = H.mkFactBase constLattice []
      rc (NodeTerm (T (Branch l)) _) f = H.mapSingleton (hooplLabelFor l) f

      -- if we take the false branch of a CondBranch then the condition register contains zero
      rc (NodeTerm (T (CondBranch (Reg x) tl fl)) _) f
        = H.mkFactBase constLattice
               [(hooplLabelFor tl, f),
                (hooplLabelFor fl, Map.insert x (H.PElem 0) f)]

    -- rewrite function: replace use of reg with constant contents
    constProp :: forall m. H.FuelMonad m => (Label -> H.Label) -> H.FwdRewrite m (Node Instruction) ConstFact
    constProp hooplLabelFor = H.mkFRewrite cp
     where
       cp :: Node Instruction e x -> ConstFact -> m (Maybe (H.Graph (Node Instruction) e x))
       cp node f
         = return $ rw hooplLabelFor (lookup f) node

       rw :: (Label -> H.Label) -> (Register -> Maybe Integer) -> Node Instruction e x -> (Maybe (H.Graph (Node Instruction) e x))
       rw hooplLabelFor valueOf inst =
         case inst of
           -- if we see a subtract with constant, turn it into a SubI
           (NodeCont (O (Sub (Reg x) (Reg y)))) ->
             case (valueOf x, valueOf y) of
               (Just xi, _) -> Just $ H.mkMiddle $ NodeCont $ O $ SubI xi (Reg y)
               (_, Just yi) -> Just $ H.mkMiddle $ NodeCont $ O $ SubI yi (Reg x)
               _            -> Nothing

           -- if we see a CondBranch on a constant, turn it into a Branch
           (NodeTerm (T (CondBranch (Reg x) tl fl)) _) ->
             case (valueOf x) of
              (Just xi) ->
                if 0 == xi then
                  Just $ H.mkLast $ NodeTerm (T $ Branch fl) [hooplLabelFor fl]
                else
                  Just $ H.mkLast $ NodeTerm (T $ Branch tl) [hooplLabelFor tl]
              _ -> Nothing
           _ -> Nothing

       lookup :: ConstFact -> Register -> Maybe Integer
       lookup f x = case Map.lookup x f of
                      Just (H.PElem v) -> Just v
                      _                -> Nothing

    constPropPass :: H.FuelMonad m => (Label -> H.Label) -> H.FwdPass m (Node Instruction) ConstFact
    constPropPass hooplLabelFor = H.FwdPass
      { H.fp_lattice  = constLattice
      , H.fp_transfer = regIsConstant hooplLabelFor
      , H.fp_rewrite  = constProp hooplLabelFor
      }

    runConstProp :: (H.CheckpointMonad m, H.FuelMonad m) => [Register] -> (Label -> H.Label) -> H.Label -> (H.Graph (Node Instruction) H.C H.C) -> m (H.Graph (Node Instruction) H.C H.C)
    runConstProp registers hooplLabelFor entry graph = do
      (graph', _, _) <- H.analyzeAndRewriteFwd (constPropPass hooplLabelFor) (H.JustC [entry]) graph (H.mapSingleton entry $ initFact registers)
      return graph'

HUnit 输出为：

hoopl_6: [Failed]
  expected: [L (Label "entry"),O (Sub (Reg "r0") (Reg "r0")),T (Branch (Label "fb")),L (Label "fb"),O (SubI 0 (Reg "r2")),T Halt]
  but got: [L (Label "entry"),O (Sub (Reg "r0") (Reg "r0")),T (Branch (Label "fb"))]

标签： haskellcompiler-constructionhoopl

Answer 1

事实证明，问题确实不在这段代码中。

我没有在顶层输入标签映射单子，而是在转换的叶子中放置了对 runLabelMapM 的单独调用，这意味着我不小心为程序中的每个用户标签分配了唯一的 Hoopl 标签，而不是重用 Hoopl程序重用用户标签的标签。

当然，这意味着 agoto L3和后续代码中的匹配L3:被映射到不同的Hoopl 标签，而不是同一个 Hoopl 标签；true 和 false 分支块是绝对无法访问的，因为在 Hoopl 看来，它们看起来好像是我写的：

block_cprop_in_0 = [ --test for constprop
                     L $ Label "1",
                     O $ Sub (Reg "r0") (Reg "r0"),
                     T $ CondBranch (Reg "r0") (Label "2") (Label "3")
                   ]

block_cprop_in_1 = [ -- test for constprop
                     L $ Label "4",
                     O $ Sub (Reg "r1") (Reg "r0"),
                     T $ Halt
                   ] -- this block is unreachable from the CondBranch in block_cprop_in_0

block_cprop_in_2 = [ -- test for constprop
                     L $ Label "5",
                     O $ Sub (Reg "r2") (Reg "r0"), --should get rewritten as a SubI
                     T $ Halt
                   ]

最后只是一个单子线程陷阱！

对于后代，这是正确的代码：我只需要将函数runHooplLabelMapM外部提升toHoopl到顶层。

test_hoopl_6 =
  let p = [block_cprop_in_0, block_cprop_in_1, block_cprop_in_2]
      p' :: (H.Graph (Node Instruction) H.C H.C) = H.runSimpleUniqueMonad $ H.runWithFuel H.infiniteFuel $ ((transform p) :: H.SimpleFuelMonad (H.Graph (Node Instruction) H.C H.C))
      unP' :: [Instruction] = fromHoopl p'
  in unP' @?= block_cprop_out
  where
    convert prog = do
      ps <- forM prog (toHoopl @[] @Instruction @Label)
      let p = foldl (H.|*><*|) H.emptyClosedGraph ps
      return p

    transform :: (H.CheckpointMonad m, H.FuelMonad m, H.UniqueMonad m) => [[Instruction]] -> m (H.Graph (Node Instruction) H.C H.C)
    transform p = do
      (hlm, prog) <- runHooplLabelMapM Map.empty $ convert p
      let registers = ["r0", "r1", "r2", "r3"]
      let hooplLabelFor = fromJust . flip Map.lookup hlm
      let eLabel = hooplLabelFor $ Label "entry"
      p' <- runConstProp registers hooplLabelFor eLabel prog
      return p'

...