Various fixes for SemRef handling, Array ST (#94)

* Don't inline unsafeThaw, fixes #92

* Don't deref arbitrary primops when negating, fixes #93

* Add back in boolean or chaining

* Cleanup ST Array methods

* Update snapshots

* Add test:output-diff to CI

* Pre-emptively inline calls to pushImpl, which is currently unreleased

* Fix inlining of uncurried st operations

* Add esbuild to CI

* Update quotes in command

* Disable output-diff on windows

.github/workflows/ci.yml

@@ -34,7 +34,7 @@ jobs:
             ${{ runner.os }}-
 
       - name: Setup PureScript dependencies
-        run: npm i --global purescript@0.15.10 purs-tidy@latest spago@latest purescript-psa@latest
+        run: npm i --global purescript@0.15.10 purs-tidy@latest spago@latest purescript-psa@latest esbuild@latest
 
       - name: Cache PureScript dependencies
         uses: actions/cache@v2
@@ -53,6 +53,10 @@ jobs:
       - name: Run snapshots
         run: spago test --purs-args '--censor-lib'
 
+      - name: Test output-diff (Linux only)
+        if: matrix.os == 'ubuntu-latest'
+        run: cd backend-es && npm run test:output-diff
+
       - name: Check formatting (Linux only)
         if: matrix.os == 'ubuntu-latest'
         run: npm run format:check

backend-es/package.json

@@ -19,7 +19,7 @@
     "postversion": "git commit -m \"Bump purs-backend-es version ($npm_package_version)\" && git tag purs-backend-es-v$npm_package_version",
     "test": "cd .. && spago test",
     "test:output-diff": "npm run build && cd ../ && ./backend-es/index.js build --timing --int-tags --output-dir=output-es2 && diff -r output-es output-es2 && rm -r output-es2",
-    "build": "cd .. && spago build -u '-g corefn,js' && node ./backend-es/index.dev.js bundle-module -m Main --timing --int-tags --platform=node --minify --to=./backend-es/bundle/index.js",
+    "build": "cd .. && spago build -u \"-g corefn,js\" && node ./backend-es/index.dev.js bundle-module -m Main --timing --int-tags --platform=node --minify --to=./backend-es/bundle/index.js",
     "prepublishOnly": "rm -rf bundle ../output ../output-es && npm run build"
   },
   "repository": {

backend-es/src/PureScript/Backend/Optimizer/Codegen/EcmaScript/Convert.purs

@@ -272,7 +272,9 @@ codegenExpr env@(CodegenEnv { currentModule, inlineApp }) tcoExpr@(TcoExpr _ exp
   UncurriedEffectApp a bs ->
     case a of
       TcoExpr _ (Var qual)
-        | Just expr' <- inlineApp env qual (InlineEffectApp bs) ->
+        -- This is intentionally invoking this with InlineApp as we
+        -- are in a "pure" context, rather than binding an uncurried effect.
+        | Just expr' <- inlineApp env qual (InlineApp bs) ->
             expr'
       _ ->
         codegenEffectBlock env tcoExpr
@@ -465,13 +467,18 @@ codegenBlockBranches mode env bs def = case mode.return of
       Tuple (codegenExpr env a) $ codegenBlockStatements mode env b
 
 codegenBindEffect :: CodegenEnv -> TcoExpr -> EsExpr
-codegenBindEffect env tcoExpr@(TcoExpr _ expr) = case expr of
+codegenBindEffect env@(CodegenEnv { inlineApp }) tcoExpr@(TcoExpr _ expr) = case expr of
   PrimEffect a ->
     codegenPrimEffect env a
   Branch _ _ ->
     build $ EsCall (esArrowFunction [] (codegenBlockStatements effectMode env tcoExpr)) []
   UncurriedEffectApp a bs ->
-    build $ EsCall (codegenExpr env a) (EsArrayValue <<< codegenExpr env <$> bs)
+    case a of
+      TcoExpr _ (Var qual)
+        | Just expr' <- inlineApp env qual (InlineEffectApp bs) ->
+            expr'
+      _ ->
+        build $ EsCall (codegenExpr env a) (EsArrayValue <<< codegenExpr env <$> bs)
   _ ->
     build $ EsCall (codegenExpr env tcoExpr) []
 

backend-es/src/PureScript/Backend/Optimizer/Codegen/EcmaScript/Foreign.purs

@@ -15,16 +15,15 @@ import PureScript.Backend.Optimizer.Semantics.Foreign (ForeignEval, ForeignSeman
 import PureScript.Backend.Optimizer.Syntax (BackendOperator(..), BackendOperator1(..), BackendOperator2(..), BackendOperatorOrd(..))
 import PureScript.Backend.Optimizer.Utils (foldr1Array)
 
+-- NOTE: As a precaution, do not inline ST "thaw" functions to an unsafe
+-- coercion as the optimizer may analyze the binding as a known immutable value.
 esForeignSemantics :: Map (Qualified Ident) ForeignEval
 esForeignSemantics = Map.fromFoldable
   [ control_monad_st_internal_for
   , control_monad_st_internal_foreach
   , control_monad_st_internal_while
   , data_array_indexImpl
-  , data_array_st_push
-  , data_array_st_unshift
   , data_array_st_unsafeFreeze
-  , data_array_st_unsafeThaw
   , data_bounded_topInt
   , data_bounded_bottomInt
   , data_bounded_topChar
@@ -71,29 +70,9 @@ data_array_indexImpl = Tuple (qualified "Data.Array" "indexImpl") go
     _ ->
       Nothing
 
-data_array_st_push :: ForeignSemantics
-data_array_st_push = Tuple (qualified "Data.Array.ST" "push") $ arraySTAll (qualified "Data.Array.ST" "pushAll")
-
-data_array_st_unshift :: ForeignSemantics
-data_array_st_unshift = Tuple (qualified "Data.Array.ST" "unshift") $ arraySTAll (qualified "Data.Array.ST" "unshiftAll")
-
-arraySTAll :: Qualified Ident -> ForeignEval
-arraySTAll ident env _ = case _ of
-  [ ExternApp [ val ] ] ->
-    Just $
-      makeLet Nothing val \nextVal ->
-        SemLam Nothing \nextRef ->
-          SemEffectDefer $
-            evalApp env (NeutStop ident) [ NeutLit (LitArray [ nextVal ]), nextRef ]
-  _ ->
-    Nothing
-
 data_array_st_unsafeFreeze :: ForeignSemantics
 data_array_st_unsafeFreeze = Tuple (qualified "Data.Array.ST" "unsafeFreeze") unsafeSTCoerce
 
-data_array_st_unsafeThaw :: ForeignSemantics
-data_array_st_unsafeThaw = Tuple (qualified "Data.Array.ST" "unsafeThaw") unsafeSTCoerce
-
 unsafeSTCoerce :: ForeignEval
 unsafeSTCoerce _ _ = case _ of
   [ ExternApp [ ref ] ] ->

backend-es/src/PureScript/Backend/Optimizer/Codegen/EcmaScript/Inline.purs

@@ -25,9 +25,15 @@ esInlineMap = Map.fromFoldable
   , control_monad_st_internal_foreach
   , control_monad_st_internal_run
   , control_monad_st_internal_while
+  , data_array_st_freezeImpl
+  , data_array_st_thawImpl
   , data_array_st_new
   , data_array_st_pushAll
+  , data_array_st_pushAllImpl
+  , data_array_st_pushImpl
+  , data_array_st_unsafeThawImpl
   , data_array_st_unshiftAll
+  , data_array_st_unshiftAllImpl
   , data_semigroup_concatArray
   , effect_forE
   , effect_foreachE
@@ -62,6 +68,28 @@ control_monad_st_internal_foreach = Tuple (qualified "Control.Monad.ST.Internal"
 control_monad_st_internal_while :: EsInline
 control_monad_st_internal_while = Tuple (qualified "Control.Monad.ST.Internal" "while") whileLoop
 
+data_array_st_freezeImpl :: EsInline
+data_array_st_freezeImpl = Tuple (qualified "Data.Array.ST" "freezeImpl") arrayCopy
+
+data_array_st_thawImpl :: EsInline
+data_array_st_thawImpl = Tuple (qualified "Data.Array.ST" "thawImpl") arrayCopy
+
+arrayCopy :: EsInlineCall
+arrayCopy env _ = case _ of
+  InlineEffectApp [ a ] ->
+    Just $ build $ EsArray [ EsArraySpread (codegenExpr env a) ]
+  _ ->
+    Nothing
+
+data_array_st_unsafeThawImpl :: EsInline
+data_array_st_unsafeThawImpl = Tuple (qualified "Data.Array.ST" "unsafeThawImpl") go
+  where
+  go env _ = case _ of
+    InlineEffectApp [ TcoExpr _ (Lit (LitArray arr)) ] ->
+      Just $ build $ EsArray $ EsArrayValue <<< codegenExpr env <$> arr
+    _ ->
+      Nothing
+
 data_array_st_new :: EsInline
 data_array_st_new = Tuple (qualified "Data.Array.ST" "new") go
   where
@@ -74,9 +102,18 @@ data_array_st_new = Tuple (qualified "Data.Array.ST" "new") go
 data_array_st_pushAll :: EsInline
 data_array_st_pushAll = Tuple (qualified "Data.Array.ST" "pushAll") $ arraySTAll "push"
 
+data_array_st_pushAllImpl :: EsInline
+data_array_st_pushAllImpl = Tuple (qualified "Data.Array.ST" "pushAllImpl") $ arraySTAllImpl "push"
+
+data_array_st_pushImpl :: EsInline
+data_array_st_pushImpl = Tuple (qualified "Data.Array.ST" "pushImpl") $ arraySTImpl "push"
+
 data_array_st_unshiftAll :: EsInline
 data_array_st_unshiftAll = Tuple (qualified "Data.Array.ST" "unshiftAll") $ arraySTAll "unshift"
 
+data_array_st_unshiftAllImpl :: EsInline
+data_array_st_unshiftAllImpl = Tuple (qualified "Data.Array.ST" "unshiftAllImpl") $ arraySTAllImpl "unshift"
+
 arraySTAll :: String -> EsInlineCall
 arraySTAll method env _ = case _ of
   InlineApp [ TcoExpr _ (Lit (LitArray vals)), arr ] ->
@@ -86,6 +123,22 @@ arraySTAll method env _ = case _ of
   _ ->
     Nothing
 
+arraySTAllImpl :: String -> EsInlineCall
+arraySTAllImpl method env _ = case _ of
+  InlineEffectApp [ TcoExpr _ (Lit (LitArray vals)), arr ] ->
+    Just $ build $ EsCall (build (EsAccess (codegenExpr env arr) method)) $ EsArrayValue <<< codegenExpr env <$> vals
+  InlineEffectApp [ vals, arr ] ->
+    Just $ build $ EsCall (build (EsAccess (codegenExpr env arr) method)) $ spreadConcatArray $ codegenExpr env vals
+  _ ->
+    Nothing
+
+arraySTImpl :: String -> EsInlineCall
+arraySTImpl method env _ = case _ of
+  InlineEffectApp [ val, arr ] ->
+    Just $ build $ EsCall (build (EsAccess (codegenExpr env arr) method)) [ EsArrayValue (codegenExpr env val) ]
+  _ ->
+    Nothing
+
 data_semigroup_concatArray :: EsInline
 data_semigroup_concatArray = Tuple (qualified "Data.Semigroup" "concatArray") go
   where

backend-es/src/PureScript/Backend/Optimizer/Codegen/EcmaScript/Syntax.purs

@@ -313,6 +313,8 @@ build syn = case syn of
     | otherwise -> do
         let Tuple s cs' = buildStatements cs
         EsExpr (bumpSize (esAnalysisOf b <> s)) $ EsForOf a b cs'
+  EsUnary EsNot (EsExpr _ (EsBinary EsEquals a b)) ->
+    build $ EsBinary EsNotEquals a b
   _ ->
     EsExpr (pureAnn (bumpSize (foldMap esAnalysisOf syn))) syn
     where

backend-es/test/snapshots-out/Snapshot.HalogenVDomST02.js

@@ -1,5 +1,4 @@
 import * as Assert from "../Assert/index.js";
-import * as Data$dArray$dST from "../Data.Array.ST/index.js";
 import * as Data$dEq from "../Data.Eq/index.js";
 import * as Data$dShow from "../Data.Show/index.js";
 import * as Snapshot$dHalogenVDomST01 from "../Snapshot.HalogenVDomST01/index.js";
@@ -26,9 +25,9 @@ const main = () => {
       return {ix, a: "", b};
     }
   );
-  const m1 = Data$dArray$dST.freeze(merged1)();
-  const a1 = Data$dArray$dST.freeze(added1)();
-  const d1 = Data$dArray$dST.freeze(deleted1)();
+  const m1 = [...merged1];
+  const a1 = [...added1];
+  const d1 = [...deleted1];
   assertEqual("diffWithIxE/merged")({expected: [{a: "1", b: 1}, {a: "2", b: 2}], actual: m1})();
   Assert.assertEqual({eq: Data$dEq.eqArrayImpl(Data$dEq.eqIntImpl)})({show: Data$dShow.showArrayImpl(Data$dShow.showIntImpl)})("diffWithIxE/added")({expected: [], actual: a1})();
   Assert.assertEqual({eq: Data$dEq.eqArrayImpl(Data$dEq.eqStringImpl)})({show: Data$dShow.showArrayImpl(Data$dShow.showStringImpl)})("diffWithIxE/deleted")({

backend-es/test/snapshots-out/Snapshot.PrimOpBooleanNotRegression.js

@@ -0,0 +1,5 @@
+const test = comp => a => b => {
+  const $0 = comp(a)(b);
+  return $0 === "LT" || $0 === "GT" || $0 !== "EQ";
+};
+export {test};

backend-es/test/snapshots-out/Snapshot.STArray05.js

@@ -0,0 +1,9 @@
+const test = x => {
+  const $0 = x ? (a => () => a.push(1)) : a => () => a.unshift(2);
+  return (() => {
+    const arr = [];
+    $0(arr)();
+    return arr;
+  })();
+};
+export {test};

backend-es/test/snapshots-out/Snapshot.STArrayUnsafeThawFreezeLengthRegression.js

@@ -0,0 +1,7 @@
+const test = x => {
+  const result = [x];
+  result.push(12);
+  result.push(result.length);
+  return result;
+};
+export {test};

backend-es/test/snapshots/Snapshot.PrimOpBooleanNotRegression.purs

@@ -0,0 +1,9 @@
+module Snapshot.PrimOpBooleanNotRegression where
+
+import Prelude
+
+-- Related to #93.
+-- Inlines to multiple references to the result of comp. The call
+-- to comp should not be duplicated due to OpBooleanNot.
+test :: forall a. (a -> a -> Ordering) -> a -> a -> Boolean
+test comp a b = comp a b /= EQ

backend-es/test/snapshots/Snapshot.STArray05.purs

@@ -0,0 +1,16 @@
+module Snapshot.STArray05 (test) where
+
+import Prelude
+
+import Control.Monad.ST (ST)
+import Data.Array.ST (STArray)
+import Data.Array.ST as STArray
+
+f :: forall h. (STArray h Int -> ST h Int) -> ST h (STArray h Int)
+f eff = do
+  arr <- STArray.new
+  _ <- eff arr
+  pure arr
+
+test :: Boolean -> Array Int
+test x = STArray.run (f (if x then \a -> STArray.push 1 a else \a -> STArray.unshift 2 a))

backend-es/test/snapshots/Snapshot.STArrayUnsafeThawFreezeLengthRegression.purs

@@ -0,0 +1,18 @@
+module Snapshot.STArrayUnsafeThawFreezeLengthRegression where
+
+import Prelude
+
+import Control.Monad.ST as ST
+import Data.Array as Array
+import Data.Array.ST as STA
+
+-- Related to #92.
+-- The call to `Array.length` should not inline to a constant value.
+
+test :: Int -> Array Int
+test x = ST.run do
+  result <- STA.unsafeThaw $ Array.singleton x
+  _ <- STA.push 12 result
+  len <- Array.length <$> STA.unsafeFreeze result
+  _ <- STA.push len result
+  STA.unsafeFreeze result

src/PureScript/Backend/Optimizer/Directives/Defaults.purs

@@ -37,6 +37,21 @@ defaultDirectives =
   Control.Semigroupoid.composeFlipped arity=1
   Control.Semigroupoid.semigroupoidFn.compose arity=2
 
+  Data.Array.ST.freeze arity=1
+  Data.Array.ST.length arity=1
+  Data.Array.ST.pop arity=1
+  Data.Array.ST.poke arity=3
+  Data.Array.ST.peek arity=2
+  Data.Array.ST.pushAll arity=2
+  Data.Array.ST.push arity=2
+  Data.Array.ST.thaw arity=1
+  Data.Array.ST.toAssocArray arity=1
+  Data.Array.ST.shift arity=1
+  Data.Array.ST.unsafeFreeze arity=1
+  Data.Array.ST.unsafeThaw arity=1
+  Data.Array.ST.unshift arity=2
+  Data.Array.ST.unshiftAll arity=2
+
   Data.Boolean.otherwise always
 
   Data.Bounded.boundedRecordCons arity=5

src/PureScript/Backend/Optimizer/Semantics.purs

@@ -632,7 +632,7 @@ evalPrimOp env = case _ of
         | NeutLit (LitBoolean bool) <- deref x ->
             liftBoolean (not bool)
       OpBooleanNot, _
-        | NeutPrimOp op <- deref x ->
+        | NeutPrimOp op <- x ->
             evalPrimOpNot op
       OpIntBitNot, _
         | NeutLit (LitInt a) <- deref x ->
@@ -1360,11 +1360,26 @@ simplifyCondBoolean ctx = case _, _ of
         Just expr
     | not body' && other ->
         Just $ build ctx $ PrimOp (Op1 OpBooleanNot expr)
+  Pair expr (ExprSyntax _ (Lit (LitBoolean true))), other
+    | isSimplePredicate other ->
+        Just $ build ctx $ PrimOp (Op2 OpBooleanOr expr other)
   Pair expr body, ExprSyntax _ (Lit (LitBoolean false)) ->
     Just $ build ctx $ PrimOp (Op2 OpBooleanAnd expr body)
   _, _ ->
     Nothing
 
+isSimplePredicate :: BackendExpr -> Boolean
+isSimplePredicate = case _ of
+  ExprSyntax _ expr ->
+    case expr of
+      Lit _ -> true
+      Var _ -> true
+      Local _ _ -> true
+      PrimOp _ -> true
+      _ -> false
+  _ ->
+    false
+
 simplifyCondRedundantElse :: Ctx -> Pair BackendExpr -> BackendExpr -> Maybe BackendExpr
 simplifyCondRedundantElse ctx = case _, _ of
   Pair expr1 body1, ExprSyntax _ (Branch pairs _)