Native Data.Int.Bits intrinsics; fix a dropped perform of user Effect functions

binaryen/src/Binaryen.js

@@ -87,6 +87,18 @@ export const i32AndImpl = (mod) => (left) => (right) => () =>
 export const i32OrImpl = (mod) => (left) => (right) => () =>
   mod.i32.or(left, right);
 
+export const i32XorImpl = (mod) => (left) => (right) => () =>
+  mod.i32.xor(left, right);
+
+export const i32ShlImpl = (mod) => (left) => (right) => () =>
+  mod.i32.shl(left, right);
+
+export const i32ShrSImpl = (mod) => (left) => (right) => () =>
+  mod.i32.shr_s(left, right);
+
+export const i32ShrUImpl = (mod) => (left) => (right) => () =>
+  mod.i32.shr_u(left, right);
+
 export const i32EqzImpl = (mod) => (value) => () =>
   mod.i32.eqz(value);
 
@@ -303,4 +315,4 @@ export const validateImpl = (mod) => () => mod.validate() !== 0;
 
 export const emitTextImpl = (mod) => () => mod.emitText();
 
-export const emitBinaryImpl = (mod) => () => mod.emitBinary();
+export const emitBinaryImpl = (mod) => () => mod.emitBinary();

binaryen/src/Binaryen.purs

@@ -41,6 +41,10 @@ module Binaryen
   , i32LtS
   , i32And
   , i32Or
+  , i32Xor
+  , i32Shl
+  , i32ShrS
+  , i32ShrU
   , i32Eqz
   , i32Const
   , i32TruncF64S
@@ -284,6 +288,30 @@ foreign import i32OrImpl :: Module -> Expression -> Expression -> Effect Express
 i32Or :: Module -> Expression -> Expression -> Effect Expression
 i32Or = i32OrImpl
 
+foreign import i32XorImpl :: Module -> Expression -> Expression -> Effect Expression
+
+-- | `i32.xor`: bitwise XOR.
+i32Xor :: Module -> Expression -> Expression -> Effect Expression
+i32Xor = i32XorImpl
+
+foreign import i32ShlImpl :: Module -> Expression -> Expression -> Effect Expression
+
+-- | `i32.shl`: logical left shift (`left << (right & 31)`).
+i32Shl :: Module -> Expression -> Expression -> Effect Expression
+i32Shl = i32ShlImpl
+
+foreign import i32ShrSImpl :: Module -> Expression -> Expression -> Effect Expression
+
+-- | `i32.shr_s`: arithmetic right shift, sign-propagating (PureScript `shr`, JS `>>`).
+i32ShrS :: Module -> Expression -> Expression -> Effect Expression
+i32ShrS = i32ShrSImpl
+
+foreign import i32ShrUImpl :: Module -> Expression -> Expression -> Effect Expression
+
+-- | `i32.shr_u`: logical right shift, zero-filling (PureScript `zshr`, JS `>>>`).
+i32ShrU :: Module -> Expression -> Expression -> Effect Expression
+i32ShrU = i32ShrUImpl
+
 foreign import i32EqzImpl :: Module -> Expression -> Effect Expression
 
 -- | `i32.eqz`: 1 if the operand is 0, 0 otherwise (logical NOT of a 0/1 value).
@@ -569,4 +597,4 @@ foreign import emitBinaryImpl :: Module -> Effect Uint8Array
 
 -- | Emit the module as a wasm binary.
 emitBinary :: Module -> Effect Uint8Array
-emitBinary = emitBinaryImpl
+emitBinary = emitBinaryImpl

compiler/src/PureScript/Backend/Wasm/Codegen/Prim.purs

@@ -257,6 +257,18 @@ genPrim ctx intr args = case intr, args of
     nothingElse <- genAtomAs ctx Boxed nothing
     inner <- B.if_ ctx.mod isInt justApplied nothingThen
     B.if_ ctx.mod guardE inner nothingElse
+  -- `Data.Int.Bits`: single i32 instructions. `IntShr` is arithmetic
+  -- (sign-propagating, JS `>>`); `IntZshr` is logical (zero-fill, JS `>>>`).
+  IntAnd, [ a, b ] -> intBinop B.i32And a b
+  IntOr, [ a, b ] -> intBinop B.i32Or a b
+  IntXor, [ a, b ] -> intBinop B.i32Xor a b
+  IntShl, [ a, b ] -> intBinop B.i32Shl a b
+  IntShr, [ a, b ] -> intBinop B.i32ShrS a b
+  IntZshr, [ a, b ] -> intBinop B.i32ShrU a b
+  IntComplement, [ a ] -> do
+    ea <- intArg a
+    m1 <- B.i32Const ctx.mod (-1)
+    B.i32Xor ctx.mod ea m1
   _, _ -> throwException (error "Codegen: intrinsic given an operand list of the wrong arity")
   where
   -- operand at the representation the op needs (no-op if already that rep)

compiler/src/PureScript/Backend/Wasm/Intrinsics.purs

@@ -143,6 +143,16 @@ data Intrinsic
   -- | applying it to the unit (the erased `Partial` dictionary). Native so the wasm
   -- | closure never crosses to the JS foreign (which would call it as `f()`).
   | UnsafePartial
+  -- | `Data.Int.Bits` 32-bit bitwise ops (JS `& | ^ << >> >>> ~`), each a single
+  -- | i32 instruction. `IntShr` is *arithmetic* (sign-propagating, JS `>>`);
+  -- | `IntZshr` is *logical* (zero-fill, JS `>>>`); `IntComplement x` = `x ^ -1`.
+  | IntAnd
+  | IntOr
+  | IntXor
+  | IntShl
+  | IntShr
+  | IntZshr
+  | IntComplement
 
 derive instance eqIntrinsic :: Eq Intrinsic
 derive instance genericIntrinsic :: Generic Intrinsic _
@@ -232,9 +242,9 @@ foreignIntrinsic = case _ of
 -- | Intrinsics resolved by *qualified* name (rather than the bare identifier the table
 -- | above uses): the `effect`-package primitives — `Effect.Ref` cell ops (ADR
 -- | 0017) and the `Effect` control-flow loops (ADR 0018) — plus
--- | `Partial.Unsafe._unsafePartial`, a couple of `Data.Array` ops, and the
--- | uncurried-function families. Qualified because names like `read` / `write` / `new`
--- | / `forE` are too generic to claim globally.
+-- | `Partial.Unsafe._unsafePartial`, a couple of `Data.Array` ops, the `Data.Int.Bits`
+-- | bitwise ops, and the uncurried-function families. Qualified because names like
+-- | `read` / `write` / `new` / `forE` / `and` / `or` are too generic to claim globally.
 -- |
 -- | The arity counts each op's value parameters plus the trailing `Effect`
 -- | perform-unit for the ops whose result is `Effect Unit` (`Ref.write`, `forE`, …):
@@ -291,6 +301,16 @@ qualifiedIntrinsic = case _ of
   "Wasm.Int.lt" -> Just (Tuple IntLt 2)
   "Wasm.Int.div" -> Just (Tuple IntDiv 2)
   "Wasm.Int.mod" -> Just (Tuple IntMod 2)
+  -- `Data.Int.Bits` 32-bit bitwise ops (the `integers` package foreigns: bare
+  -- `and`/`or`/`xor`/`shl`/`shr`/`zshr`/`complement`, qualified here because the
+  -- bare names are too generic). Pure, so absent from `effectfulForeignNames`.
+  "Data.Int.Bits.and" -> Just (Tuple IntAnd 2)
+  "Data.Int.Bits.or" -> Just (Tuple IntOr 2)
+  "Data.Int.Bits.xor" -> Just (Tuple IntXor 2)
+  "Data.Int.Bits.shl" -> Just (Tuple IntShl 2)
+  "Data.Int.Bits.shr" -> Just (Tuple IntShr 2)
+  "Data.Int.Bits.zshr" -> Just (Tuple IntZshr 2)
+  "Data.Int.Bits.complement" -> Just (Tuple IntComplement 1)
   -- `reverse`/`sliceImpl`/`indexImpl`/`unconsImpl`, `Data.Foldable.fold{l,r}Array`,
   -- `Data.String.CodeUnits.{singleton,toCharArray,fromCharArray}`, `Data.Int.fromStringAsImpl`
   -- now live in `ulib/<Module>/foreign.wat` (ADR 0012), resolved as merged foreigns.
@@ -325,4 +345,4 @@ effectfulForeignNames = Set.fromFoldable
   , "Effect.foreachE"
   , "Effect.whileE"
   , "Effect.untilE"
-  ]
+  ]

compiler/src/PureScript/Backend/Wasm/Lower.purs

@@ -119,13 +119,17 @@ isEffectForeignApp env = case _ of
   M.Var q -> isEff q
   _ -> false
   where
-  -- An intrinsic (incl. the `Effect.Ref` ops and `modifyImpl`, ADR 0017) is NOT a host
-  -- foreign: it is performed via the unit-application path (so its arity includes the
-  -- perform-unit), even though source reconstruction (ADR 0016) also lists it in
-  -- `foreignSigs` with an `MEffect` result. Exclude it here so that path is taken.
   isEff q@(Qualified _ ident)
     | isJust (qualifiedIntrinsic (qualifiedKeyOf q)) = false
     | isJust (foreignIntrinsic ident) = false
+    -- A user-defined top-level function has a decl body, so it is in `knownFuncs`; it is
+    -- NOT a host foreign. It is performed via the unit-application path (its arity includes
+    -- the perform-unit, ADR 0018), even though source reconstruction (ADR 0016) also lists
+    -- it in `foreignSigs` with an `MEffect` result. Without this exclusion, a performed
+    -- partial application of such a function (`perform (bad "x")`) is misrouted to the
+    -- host-foreign path and lowered as a bare producer value — a partial closure that is
+    -- built but never applied to the unit, silently dropping the effect.
+    | Object.member (qualifiedKeyOf q) env.knownFuncs = false
     | otherwise = case Object.lookup (qualifiedKeyOf q) env.foreignSigs of
         Just sig -> case sig.result of
           MEffect _ -> true
@@ -198,9 +202,16 @@ lowerArg env expr k = case expr of
   -- collapse removes most `Perform`s in the simplifier.)
   M.Perform e
     | isEffectForeignApp env e -> lowerArg env e k
+    -- A performed application of a non-foreign producer: append the perform unit to the
+    -- producer's OWN argument list, so the whole thing lowers as one application. A function
+    -- whose arity includes the perform-unit (ADR 0018) then saturates to a *direct*
+    -- `RCallKnown` (the same direct shape a foreign perform takes), and `applyArity` still
+    -- handles the over-applied case (call saturated, apply the unit to the result). The old
+    -- `head: e` form passed the application itself as the head, hit the closure/`RApply`
+    -- fallback, built the producer as a partial closure, and dropped the apply that feeds
+    -- the unit — silently discarding the effect.
+    | M.App h as <- e -> lowerApp env { head: h, args: as <> [ M.Lit (LitInt 0) ] } k
     | otherwise -> lowerApp env { head: e, args: [ M.Lit (LitInt 0) ] } k
-  -- An (uncurried) lambda lowers to a closure; closures are arity-1, so a
-  -- multi-parameter lambda peels one parameter and the rest stay an inner lambda.
   M.Abs params body -> case Array.uncons params of
     Nothing -> lowerArg env body k
     Just { head: param, tail } -> do
@@ -518,17 +529,6 @@ recBindEtaArity env = case _ of
       <|> (snd <$> (qualifiedIntrinsic (qualifiedKeyOf q) <|> foreignIntrinsic ident))
       <|> ((Array.length <<< _.params) <$> Object.lookup (qualifiedKeyOf q) env.foreignSigs)
 
--- | The declared arity of an application head, resolved the same way `lowerApp` dispatches a call:
--- | a constructor, a top-level/specialized function, an intrinsic, or a foreign import.
-headArity :: Env -> M.Expr -> Maybe Int
-headArity env = case _ of
-  M.Var q@(Qualified (Just _) ident) ->
-    (_.arity <$> Object.lookup (qualifiedKeyOf q) env.ctors)
-      <|> Object.lookup (qualifiedKeyOf q) env.knownFuncs
-      <|> (snd <$> (qualifiedIntrinsic (qualifiedKeyOf q) <|> foreignIntrinsic ident))
-      <|> ((Array.length <<< _.params) <$> Object.lookup (qualifiedKeyOf q) env.foreignSigs)
-  _ -> Nothing
-
 -- | Compile a `case` into a `Switch` on the scrutinee's tag, finishing each branch
 -- | with `finish` (so the same compiler serves a tail-position `case` — `finish =
 -- | lowerTail` — and an argument-position one, where `finish` feeds the branch

compiler/src/PureScript/Backend/Wasm/Lower/Reps.purs

@@ -22,6 +22,14 @@ primRep = case _ of
   IntDiv -> I32
   IntMod -> I32
   IntDegree -> I32
+  -- `Data.Int.Bits` 32-bit bitwise ops all produce a raw i32
+  IntAnd -> I32
+  IntOr -> I32
+  IntXor -> I32
+  IntShl -> I32
+  IntShr -> I32
+  IntZshr -> I32
+  IntComplement -> I32
   NumToInt -> I32
   StrLen -> I32
   StrByteAt -> I32 -- a UTF-8 byte (0-255), as an Int
@@ -63,6 +71,14 @@ primOperandReps = case _ of
   IntLt -> [ I32, I32 ]
   IntDegree -> [ I32 ]
   IntToNum -> [ I32 ]
+  -- `Data.Int.Bits`: both operands unboxed i32 (the shift count too)
+  IntAnd -> [ I32, I32 ]
+  IntOr -> [ I32, I32 ]
+  IntXor -> [ I32, I32 ]
+  IntShl -> [ I32, I32 ]
+  IntShr -> [ I32, I32 ]
+  IntZshr -> [ I32, I32 ]
+  IntComplement -> [ I32 ]
   FromNumberImpl -> [ Boxed, Boxed, F64 ] -- just, nothing, n (the Number is unboxed)
   NumToInt -> [ F64 ]
   NumAdd -> [ F64, F64 ]
@@ -86,4 +102,4 @@ primOperandReps = case _ of
   OrdNumber -> [ Boxed, Boxed, Boxed, F64, F64 ]
   -- forE lo hi f (perform-unit): the bounds are unboxed i32, the body closure boxed
   ForE -> [ I32, I32, Boxed, Boxed ]
-  _ -> []
+  _ -> []

compiler/test/E2E/Cli.purs

@@ -24,6 +24,7 @@ import Test.E2E.Cli.FibAnd as FibAnd
 import Test.E2E.Cli.IntConv as IntConv
 import Test.E2E.Cli.Link as Link
 import Test.E2E.Cli.NestedRecordPat as NestedRecordPat
+import Test.E2E.Cli.PerformUserEffect as PerformUserEffect
 import Test.E2E.Cli.PreludeArith as PreludeArith
 import Test.E2E.Cli.PreludeBool as PreludeBool
 import Test.E2E.Cli.PreludeBounded as PreludeBounded
@@ -108,3 +109,4 @@ main = runSpecAndExitProcess [ consoleReporter ] do
   ForeignRecord.spec
   ForeignExport.spec
   ForeignEffect.spec
+  PerformUserEffect.spec

compiler/test/E2E/Cli/PerformUserEffect.purs

@@ -0,0 +1,31 @@
+-- | CLI-driven e2e (ADR 0031 phase 5) regression guard for ADR-0015: a discarded
+-- | `perform (f x)` of a NON-inlined user-defined `Effect` function must run, across the
+-- | three discard combinators (do-notation `bindBody`, `void` `mapBody`, `*>` `applyBody`).
+-- | `bump` records its argument; each entry reads the recorded total back, which equals the
+-- | sum of the bumped values iff every perform ran exactly once. Before the fix these read 0
+-- | — the performs were lowered as partial closures never applied to the perform-unit.
+module Test.E2E.Cli.PerformUserEffect (spec) where
+
+import Prelude
+
+import Effect.Class (liftEffect)
+import Test.E2E.Cli.Loader (callI32x1, loadExports)
+import Test.Spec (Spec, before, describe, it)
+import Test.Spec.Assertions (shouldEqual)
+
+spec :: Spec Unit
+spec =
+  describe "Performed user Effect fn (e2e/cli): discarded `perform (f x)` of a non-inlined user Effect fn runs across bind/map/apply discard -> purs-wasm build -> run (ADR-0015 regression)"
+    $ before (loadExports "E2E.PerformUserEffect")
+    $ do
+        it "do-notation discard (bindBody): bump 1; bump 10 => 11" \exp -> do
+          r <- liftEffect (callI32x1 exp "runBumps" 0)
+          r `shouldEqual` 11
+
+        it "void discard (mapBody): void (bump 2) => 2" \exp -> do
+          r <- liftEffect (callI32x1 exp "runVoid" 0)
+          r `shouldEqual` 2
+
+        it "applySecond discard (applyBody): bump 3 *> bump 4 => 7" \exp -> do
+          r <- liftEffect (callI32x1 exp "runSeq" 0)
+          r `shouldEqual` 7

docs/design-decisions/0017-native-mutable-references.md

@@ -3,6 +3,31 @@
 - Status: Accepted
 - Date: 2026-06-04
 
+> **Update (2026-06-18) — the `isEffectForeignApp` non-host exclusion extends to *all* known
+> functions, and the over-coverage it guards against is `Externs.foreignSigs`, not ADR 0016.**
+> A dropped-effect bug (PR #42, guard `Test.E2E.Cli.PerformUserEffect`) refined the Decision's
+> intrinsic-exclusion bullet on two points:
+> - **The `foreignSigs` over-coverage originates in `Externs.foreignSigs`, not (only) the ADR 0016
+>   source path.** `Externs.foreignSigs` is keyed off **every `EDValue` — every *exported*
+>   top-level value, ordinary functions included** — because the externs format does not flag which
+>   values are `foreign import`s (a foreign and a plain value are both `EDValue ident type`); its own
+>   doc comment notes the extra entries are "inert" *because foreign resolution only consults a sig
+>   where the name is an actual unresolved import*. ADR 0016 source reconstruction adds the
+>   *private*-foreign half on top, but a non-foreign user function (e.g. an exported
+>   `bump :: … -> Effect …`) lands in `foreignSigs` via the **externs** path, not the source path —
+>   so the Decision's "source reconstruction (ADR 0016) also lists these" is, more precisely, the
+>   externs `EDValue` coverage.
+> - **`MEffect`-result is not a sound host-foreign classifier; exclude `knownFuncs`.**
+>   `isEffectForeignApp` broke the "inert" assumption by using a sig's `MEffect` result as the
+>   *classifier* for "is this a host foreign?". An exported `Effect`-returning **user function** then
+>   matched and was lowered as a bare producer value — a partial closure built but never applied to
+>   the perform-unit — silently dropping the effect when its `perform` was discarded (`void` / `*>` /
+>   a `do` statement). The fix excludes any binding in `knownFuncs` (anything with a decl body) from
+>   the predicate, mirroring the intrinsic / `foreignIntrinsic` exclusions: a binding we have a body
+>   for is by definition not an opaque host foreign — it is performed via the unit-application path
+>   (its arity includes the perform-unit, ADR 0018), so a performed application saturates to a direct
+>   `RCallKnown`. Refs ADR 0015 (perform lowering), ADR 0018 (perform-unit arity).
+
 ## Context
 
 `Effect.Ref` (and `Control.Monad.ST`) provide a mutable cell. The standard library

e2e-fixtures/src/E2E/PerformUserEffect.js

@@ -0,0 +1,8 @@
+let recorded = 0;
+export const reset = () => {
+  recorded = 0;
+};
+export const record = (n) => () => {
+  recorded += n;
+};
+export const total = () => recorded;

e2e-fixtures/src/E2E/PerformUserEffect.purs

@@ -0,0 +1,56 @@
+-- e2e fixture (ADR 0031 phase 5): ADR-0015 regression guard. `bump` is a user-defined,
+-- deliberately un-inlinable Effect function that performs the host foreign `record`.
+-- Each entry performs `bump` with the result DISCARDED through a different combinator —
+-- do-notation (`bindBody`), `void` (`mapBody`), and `*>` (`applyBody`) — then reads the
+-- recorded total. The bug: a discarded `perform (bump k)` for a non-inlined user Effect
+-- function was misrouted to the host-foreign lowering path (`isEffectForeignApp` matched
+-- it because ADR-0016 gives it an `MEffect` reconstructed sig) and built as a partial
+-- closure never applied to the perform-unit — silently dropping the effect. `total` reads
+-- the sum of what actually ran; each entry's expected value is the sum of its bumped `k`s.
+module E2E.PerformUserEffect where
+
+import Prelude
+
+import Effect (Effect)
+import Effect.Unsafe (unsafePerformEffect)
+
+foreign import record :: Int -> Effect Unit
+foreign import total :: Effect Int
+foreign import reset :: Effect Unit
+
+-- Past the inline caps (Inline 24 / DictElim 32) and used many times, so it stays a
+-- SEPARATE binding and the call sites survive as `perform (bump k)` — the regressed path.
+-- The `record 0`s are genuine (kept) effects; pure padding would be DCE'd and could shrink
+-- `bump` back under the cap, silently reverting these tests to the inlined path.
+bump :: Int -> Effect Unit
+bump k = do
+  record k
+  record 0
+  record 0
+  record 0
+  record 0
+  record 0
+  record 0
+  record 0
+
+-- do-notation discard (bindBody path) => 1 + 10 = 11
+runBumps :: Int -> Int
+runBumps _ = unsafePerformEffect do
+  reset
+  bump 1
+  bump 10
+  total
+
+-- void / Functor-map discard (mapBody path) => 2
+runVoid :: Int -> Int
+runVoid _ = unsafePerformEffect do
+  reset
+  void (bump 2)
+  total
+
+-- applySecond / `*>` discard (applyBody path) => 3 + 4 = 7
+runSeq :: Int -> Int
+runSeq _ = unsafePerformEffect do
+  reset
+  bump 3 *> bump 4
+  total