[Git][ghc/ghc][wip/nr/indentable] 2 commits: fix bug: wasm loops don't loop; they fall through

[Norman Ramsey (@nrnrnr)]

Norman Ramsey pushed to branch wip/nr/indentable at Glasgow Haskell Compiler / GHC


Commits:
a0edb89a by Norman Ramsey at 2022-09-21T18:31:51-04:00
fix bug: wasm loops don't loop; they fall through

- - - - -
3e9e2c7c by Norman Ramsey at 2022-09-21T18:32:13-04:00
add draft Indentable module (to replace Outputable)

- - - - -


4 changed files:

- + compiler/GHC/Utils/Indentable.hs
- compiler/GHC/Wasm/ControlFlow/FromCmm.hs
- compiler/ghc.cabal.in
- testsuite/tests/wasm/should_run/control-flow/RunWasm.hs


Changes:

=====================================
compiler/GHC/Utils/Indentable.hs
=====================================
@@ -0,0 +1,54 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module GHC.Utils.Indentable
+  ( IndentedBuilder
+  , Indentation
+  , newline
+  , nestBy
+  , nest
+  , indentTo
+  , (<+>)
+  , Indentable(..)
+  )
+
+where
+
+import GHC.Prelude
+
+import Data.ByteString.Builder
+import Data.Monoid
+import Data.String
+
+type Indentation = Builder
+
+class Indentable a where
+  toIndentable :: a -> IndentedBuilder
+
+newtype IndentedBuilder = IB (Indentation -> Builder)
+
+newline :: IndentedBuilder
+newline = IB $ \indent -> "\n" <> indent
+
+instance Semigroup IndentedBuilder where
+   IB f <> IB f' = IB $ \indent -> f indent <> f' indent
+
+instance IsString IndentedBuilder where
+   fromString s = IB $ const (fromString s)
+
+instance Monoid IndentedBuilder where
+   mempty = IB $ const mempty
+
+nestBy :: Indentation -> IndentedBuilder -> IndentedBuilder
+nestBy moreIndent (IB f) = IB (\indent -> f (indent <> moreIndent))
+
+nest :: Int -> IndentedBuilder -> IndentedBuilder
+nest k = nestBy $ fromString $ take k spaces
+
+spaces :: String
+spaces = ' ' : spaces
+
+indentTo :: Indentation -> IndentedBuilder -> Builder
+indentTo indentation (IB f) = f indentation
+
+(<+>) :: IndentedBuilder -> IndentedBuilder -> IndentedBuilder
+s <+> s' = s <> " " <> s'


=====================================
compiler/GHC/Wasm/ControlFlow/FromCmm.hs
=====================================
@@ -183,8 +183,7 @@ structuredControl platform txExpr txBlock g =
                                 CmmSwitch {} -> children
                                    -- N.B. Unlike `if`, translation of Switch uses only labels.
                                 _ -> filter hasMergeRoot children
-           loopContext = LoopHeadedBy (entryLabel x) `inside`
-                           (context `withFallthrough` entryLabel x)
+           loopContext = LoopHeadedBy (entryLabel x) `inside` context
            hasMergeRoot = isMergeNode . Tree.rootLabel
 
    nodeWithin fty x (y_n:ys) (Just zlabel) context =


=====================================
compiler/ghc.cabal.in
=====================================
@@ -791,6 +791,7 @@ Library
         GHC.Utils.FV
         GHC.Utils.GlobalVars
         GHC.Utils.IO.Unsafe
+        GHC.Utils.Indentable
         GHC.Utils.Json
         GHC.Utils.Lexeme
         GHC.Utils.Logger


=====================================
testsuite/tests/wasm/should_run/control-flow/RunWasm.hs
=====================================
@@ -36,11 +36,11 @@ withPushedValue _ _ = error "looked for pushed value, but did not find one"
 
 run  :: forall s e m . ControlTestMonad s e m => Stack s e -> m ()
 run [] = return ()
-run (EndLoop s : stack) = run (Run s : EndLoop s : stack)
+run (EndLoop _ : stack) = run stack
 run (EndBlock : stack) = run stack
 run (EndIf : stack) = run stack
 run (Pushed e : frame : stack) = run (frame : Pushed e : stack)
-run (Pushed e : []) = return ()
+run (Pushed _ : []) = return ()
 run (Run s : stack) = step s
   where step :: UntypedControl s e -> m ()
         step (U WasmFallthrough) = run stack
@@ -63,7 +63,7 @@ run (Run s : stack) = step s
 
         step (U (WasmActions s)) = takeAction @s @e s >> run stack
         step (U (WasmSeq s s')) = run (Run (U s) : Run (U s') : stack)
-        br 0 (EndLoop s : stack) = run (EndLoop s : stack)
+        br 0 (EndLoop us : stack) = run (Run us : EndLoop us : stack)
         br 0 (EndBlock : stack) = run stack
         br 0 (EndIf : stack) = run stack
         br k ((Run _) : stack) = br k stack



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9023c8dbdf201aff916d74aff3f91d760f0e515c...3e9e2c7ce37d5e1a898c4ee3274622fd26050826

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9023c8dbdf201aff916d74aff3f91d760f0e515c...3e9e2c7ce37d5e1a898c4ee3274622fd26050826
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220921/5a17a4da/attachment-0001.html>