21b0f9f · rowtype-yoga/purescript-backend-optimizer

git.iko.soy/rowtype-yoga/purescript-backend-optimizer

Implement general deref for extern and locals (#73)

* Implement general deref for extern and locals * Format * Deref recursively * Cleanup evalRef * Deref within SemRef lazy to memoize pointer chasing * Add more derefs, add extern ref tests * Add deref for branching * Add inlining and runtime for more number ops * intDiv now inlines, with runtime support. * number bounded now inlines. * More reference tests * Fix snapshots * Restrict ref exprs, add snapshot for updates * Format

commit21b0f9f28c05cc642757802625f1e4a00077dc43 authorNathan Faubion <natefaubion@users.noreply.github.com> dateSun 30 Jul 2023, 12:22 (3 years ago) parent5ddaf52

29 files changed+678−174

compare with main

unifiedsplit

backend-es/runtime.js+6

@@ -25,3 +25,9 @@ export function* range(lo, hi) {

2525export function fail() {

2626 throw new Error("Failed pattern match");

2727}

28+

29+export function intDiv(x, y) {

30+ if (y > 0) return Math.floor(x / y);

31+ if (y < 0) return -Math.floor(x / -y);

32+ return 0;

33+}

backend-es/src/PureScript/Backend/Optimizer/Codegen/EcmaScript/Convert.purs+5−1

@@ -695,7 +695,11 @@ codegenPrimOp env@(CodegenEnv { options }) = case _ of

695695 OpIntBitZeroFillShiftRight ->

696696 build $ EsBinary EsZeroFillShiftRight expr1 expr2

697697 OpIntNum num ->

698− build $ EsBinary EsBitOr (build (EsBinary (numOp num) expr1 expr2)) (build (EsInt 0))

698+ case num of

699+ OpDivide ->

700+ build $ EsRuntime $ EsIntDiv expr1 expr2

701+ _ ->

702+ build $ EsBinary EsBitOr (build (EsBinary (numOp num) expr1 expr2)) (build (EsInt 0))

699703 OpIntOrd ord ->

700704 build $ EsBinary (ordOp ord) expr1 expr2

701705 OpNumberNum num ->

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

@@ -29,6 +29,8 @@ esForeignSemantics = Map.fromFoldable

2929 , data_bounded_bottomInt

3030 , data_bounded_topChar

3131 , data_bounded_bottomChar

32+ , data_bounded_topNumber

33+ , data_bounded_bottomNumber

3234 , data_enum_toCharCode

3335 , data_show_showCharImpl

3436 , data_show_showIntImpl

@@ -110,6 +112,16 @@ data_bounded_bottomInt = Tuple (qualified "Data.Bounded" "bottomInt") go

110112 where

111113 go _ _ = const $ Just $ litInt bottom

112114

115+data_bounded_topNumber :: ForeignSemantics

116+data_bounded_topNumber = Tuple (qualified "Data.Bounded" "topNumber") go

117+ where

118+ go _ _ = const $ Just $ litNumber top

119+

120+data_bounded_bottomNumber :: ForeignSemantics

121+data_bounded_bottomNumber = Tuple (qualified "Data.Bounded" "bottomNumber") go

122+ where

123+ go _ _ = const $ Just $ litNumber bottom

124+

113125data_bounded_topChar :: ForeignSemantics

114126data_bounded_topChar = Tuple (qualified "Data.Bounded" "topChar") go

115127 where

@@ -295,6 +307,9 @@ whileLoop env qual = case _ of

295307litInt :: Int -> BackendSemantics

296308litInt = NeutLit <<< LitInt

297309

310+litNumber :: Number -> BackendSemantics

311+litNumber = NeutLit <<< LitNumber

312+

298313litChar :: Char -> BackendSemantics

299314litChar = NeutLit <<< LitChar

300315

backend-es/src/PureScript/Backend/Optimizer/Codegen/EcmaScript/Syntax.purs+10−1

@@ -197,6 +197,7 @@ data EsRuntimeOp a

197197 = EsBinding a

198198 | EsRange a a

199199 | EsFail

200+ | EsIntDiv a a

200201

201202derive instance Functor EsRuntimeOp

202203

@@ -205,6 +206,7 @@ instance Foldable EsRuntimeOp where

205206 EsBinding a -> f a

206207 EsRange a b -> f a <> f b

207208 EsFail -> mempty

209+ EsIntDiv a b -> f a <> f b

208210 foldr a = foldrDefault a

209211 foldl a = foldlDefault a

210212

@@ -417,12 +419,19 @@ print opts syn = case syn of

417419 EsRuntime op ->

418420 Tuple EsPrecCall $ case op of

419421 EsBinding a ->

420− printPure opts $ esApp (Dodo.text "$runtime.binding") [ snd (print opts (syntaxOf a)) ]

422+ printPure opts $ esApp (Dodo.text "$runtime.binding")

423+ [ snd (print opts (syntaxOf a))

424+ ]

421425 EsRange a b ->

422426 esApp (Dodo.text "$runtime.range")

423427 [ snd (print opts (syntaxOf a))

424428 , snd (print opts (syntaxOf b))

425429 ]

430+ EsIntDiv a b ->

431+ printPure opts $ esApp (Dodo.text "$runtime.intDiv")

432+ [ snd (print opts (syntaxOf a))

433+ , snd (print opts (syntaxOf b))

434+ ]

426435 EsFail ->

427436 Dodo.text "$runtime.fail()"

428437 EsCall a bs -> do

backend-es/test/snapshots-out/Snapshot.InlineLocalReferenceOpArrayLength.jsdeleted−2

@@ -1,2 +0,0 @@

1−const test = fn => [];

2−export {test};

backend-es/test/snapshots-out/Snapshot.InlineLocalReferenceOpIsTag.jsdeleted−5

@@ -1,5 +0,0 @@

1−const $List = (tag, _1, _2) => ({tag, _1, _2});

2−const Cons = value0 => value1 => $List("Cons", value0, value1);

3−const Nil = /* #__PURE__ */ $List("Nil");

4−const test = fn => $List("Cons", 0, $List("Cons", 1, fn({})));

5−export {$List, Cons, Nil, test};

backend-es/test/snapshots-out/Snapshot.InlineReferenceIfThenElse.jsnew file+6

@@ -0,0 +1,6 @@

1+// @inline export fn never

2+const fn = v => 0;

3+const test1 = 42;

4+const extern1 = {a: {b: {c: true}}, d: /* #__PURE__ */ fn({})};

5+const test2 = 42;

6+export {extern1, fn, test1, test2};

backend-es/test/snapshots-out/Snapshot.InlineReferenceOpArrayLength.jsnew file+9

@@ -0,0 +1,9 @@

1+// @inline export fn' never

2+const test2 = fn => [[1, 2, fn({})], [3, 4], [fn({})]];

3+const test1 = fn => [1, 2, fn({})];

4+const fn$p = v => 0;

5+const extern1 = [1, 2, /* #__PURE__ */ fn$p({})];

6+const extern2 = [extern1, [3], [/* #__PURE__ */ fn$p({})]];

7+const test4 = extern2;

8+const test3 = extern1;

9+export {extern1, extern2, fn$p, test1, test2, test3, test4};

backend-es/test/snapshots-out/Snapshot.InlineReferenceOpIsTag.jsnew file+15

@@ -0,0 +1,15 @@

1+// @inline export fn' never

2+const $List = (tag, _1, _2) => ({tag, _1, _2});

3+const Cons = value0 => value1 => $List("Cons", value0, value1);

4+const Nil = /* #__PURE__ */ $List("Nil");

5+const test3 = fn => $List("Cons", 0, $List("Cons", 1, fn({})));

6+const test2 = fn => $List("Cons", 0, $List("Cons", 1, fn({})));

7+const test1 = fn => $List("Cons", 0, $List("Cons", 1, fn({})));

8+const fn$p = v => Nil;

9+const extern2 = {a: {b: {c: /* #__PURE__ */ $List("Cons", 1, /* #__PURE__ */ fn$p({}))}}};

10+const extern3 = {d: extern2, e: /* #__PURE__ */ fn$p({})};

11+const test6 = /* #__PURE__ */ (() => $List("Cons", 0, extern2.a.b.c))();

12+const test5 = /* #__PURE__ */ (() => $List("Cons", 0, extern2.a.b.c))();

13+const extern1 = /* #__PURE__ */ $List("Cons", 1, /* #__PURE__ */ fn$p({}));

14+const test4 = /* #__PURE__ */ $List("Cons", 0, extern1);

15+export {$List, Cons, Nil, extern1, extern2, extern3, fn$p, test1, test2, test3, test4, test5, test6};

backend-es/test/snapshots-out/Snapshot.InlineReferencePrimOpBoolean.jsnew file+10

@@ -0,0 +1,10 @@

1+// @inline export fn never

2+const fn = v => 0;

3+const test1 = 42;

4+const test2 = 42;

5+const test3 = 42;

6+const extern1 = {a: {b: {c: true}}, d: /* #__PURE__ */ fn({}), e: true, f: false};

7+const test4 = 42;

8+const test5 = 42;

9+const test6 = 42;

10+export {extern1, fn, test1, test2, test3, test4, test5, test6};

backend-es/test/snapshots-out/Snapshot.InlineReferencePrimOpInt.jsnew file+25

@@ -0,0 +1,25 @@

1+// @inline export fn never

2+// @inline export localTest always

3+// @inline export externTest always

4+const fn = v => 0;

5+const localTest = f => {

6+ const rec = {a: {b: {c: 99}}, d: fn({}), e: 11};

7+ const res = f(rec);

8+ if (res !== -2147483648) { return res; }

9+ return fn(rec);

10+};

11+const test1 = 110;

12+const test2 = 88;

13+const test3 = 1089;

14+const test4 = 9;

15+const extern = {a: {b: {c: 99}}, d: /* #__PURE__ */ fn({}), e: 11};

16+const externTest = f => {

17+ const res = f(extern);

18+ if (res !== -2147483648) { return res; }

19+ return -2147483648;

20+};

21+const test5 = 110;

22+const test6 = 88;

23+const test7 = 1089;

24+const test8 = 9;

25+export {extern, externTest, fn, localTest, test1, test2, test3, test4, test5, test6, test7, test8};

backend-es/test/snapshots-out/Snapshot.InlineReferencePrimOpNumber.jsnew file+25

@@ -0,0 +1,25 @@

1+// @inline export fn never

2+// @inline export localTest always

3+// @inline export externTest always

4+const fn = v => 0.0;

5+const localTest = f => {

6+ const rec = {a: {b: {c: 99.0}}, d: fn({}), e: 11.0};

7+ const res = f(rec);

8+ if (res !== -Infinity) { return res; }

9+ return fn(rec);

10+};

11+const test1 = 110.0;

12+const test2 = 88.0;

13+const test3 = 1089.0;

14+const test4 = 9.0;

15+const extern = {a: {b: {c: 99.0}}, d: /* #__PURE__ */ fn({}), e: 11.0};

16+const externTest = f => {

17+ const res = f(extern);

18+ if (res !== -Infinity) { return res; }

19+ return -Infinity;

20+};

21+const test5 = 110.0;

22+const test6 = 88.0;

23+const test7 = 1089.0;

24+const test8 = 9.0;

25+export {extern, externTest, fn, localTest, test1, test2, test3, test4, test5, test6, test7, test8};

backend-es/test/snapshots-out/Snapshot.InlineReferenceRecordUpdate.jsnew file+6

@@ -0,0 +1,6 @@

1+// @inline export fn' never

2+const test1 = fn => fn({}).c;

3+const fn$p = v => ({a: 1, b: 2, c: 3});

4+const extern = {.../* #__PURE__ */ fn$p({}), a: 42};

5+const test2 = /* #__PURE__ */ (() => extern.c)();

6+export {extern, fn$p, test1, test2};

backend-es/test/snapshots-out/Snapshot.PrimOpInt01.js+2−2

@@ -1,4 +1,4 @@

1−import * as Data$dEuclideanRing from "../Data.EuclideanRing/index.js";

1+import * as $runtime from "../runtime.js";

22const test9 = a => b => a * b | 0;

33const test8 = a => b => a >= b;

44const test7 = a => b => a <= b;

@@ -8,6 +8,6 @@ const test4 = a => b => a !== b;

88const test3 = a => b => a === b;

99const test2 = a => b => a - b | 0;

1010const test11 = a => -a;

11−const test10 = a => b => Data$dEuclideanRing.intDiv(a)(b);

11+const test10 = a => b => $runtime.intDiv(a, b);

1212const test1 = a => b => a + b | 0;

1313export {test1, test10, test11, test2, test3, test4, test5, test6, test7, test8, test9};

backend-es/test/snapshots-out/Snapshot.PrimOpInt02.js+1−9

@@ -1,15 +1,7 @@

1−import * as Data$dEuclideanRing from "../Data.EuclideanRing/index.js";

21const test11 = [-1, 1];

32const intValues = op => [op(1)(1), op(1)(2), op(2)(1), op(1)(-2), op(-1)(2), op(-1)(-1)];

43const test1 = [2, 3, 3, -1, 1, -2];

5−const test10 = [

6− /* #__PURE__ */ Data$dEuclideanRing.intDiv(1)(1),

7− /* #__PURE__ */ Data$dEuclideanRing.intDiv(1)(2),

8− /* #__PURE__ */ Data$dEuclideanRing.intDiv(2)(1),

9− /* #__PURE__ */ Data$dEuclideanRing.intDiv(1)(-2),

10− /* #__PURE__ */ Data$dEuclideanRing.intDiv(-1)(2),

11− /* #__PURE__ */ Data$dEuclideanRing.intDiv(-1)(-1)

12−];

4+const test10 = [1, 0, 2, 0, -1, 1];

135const test2 = [0, -1, 1, 3, -3, 0];

146const test3 = [true, false, false, false, false, true];

157const test4 = [false, true, true, true, true, false];

backend-es/test/snapshots-out/Snapshot.PrimOpIntDiv.jsnew file+15

@@ -0,0 +1,15 @@

1+// @inline export divNoInline never

2+import * as $runtime from "../runtime.js";

3+import * as Assert from "../Assert/index.js";

4+import * as Data$dEq from "../Data.Eq/index.js";

5+import * as Data$dShow from "../Data.Show/index.js";

6+const divNoInline = a => b => $runtime.intDiv(a, b);

7+const main = /* #__PURE__ */ (() => {

8+ const $0 = Assert.assertEqual(Data$dEq.eqInt)(Data$dShow.showInt)("div1")({expected: 0, actual: divNoInline(1)(0)});

9+ return () => {

10+ $0();

11+ Assert.assertEqual(Data$dEq.eqInt)(Data$dShow.showInt)("div2")({expected: 1, actual: divNoInline(3)(2)})();

12+ return Assert.assertEqual(Data$dEq.eqInt)(Data$dShow.showInt)("div3")({expected: -1, actual: divNoInline(3)(-2)})();

13+ };

14+})();

15+export {divNoInline, main};

backend-es/test/snapshots/Snapshot.InlineLocalReferenceOpArrayLength.pursdeleted−19

@@ -1,19 +0,0 @@

1−module Snapshot.InlineLocalReferenceOpArrayLength where

2−

3−import Prelude

4−

5−import Data.Array as Array

6−

7−test :: ({} -> Int) -> Array Int

8−test fn = do

9− let

10− array =

11− [ 1

12− , 2

13− , fn {}

14− ]

15− if Array.length array > 3 then

16− array

17− else

18− []

19−

backend-es/test/snapshots/Snapshot.InlineLocalReferenceOpIsTag.pursdeleted−12

@@ -1,12 +0,0 @@

1−module Snapshot.InlineLocalReferenceOpIsTag where

2−

3−data List a = Cons a (List a) | Nil

4−

5−test :: ({} -> List Int) -> List Int

6−test fn = do

7− let list = Cons 1 (fn {})

8− case list of

9− Cons _ _ ->

10− Cons 0 list

11− _ ->

12− Nil

backend-es/test/snapshots/Snapshot.InlineReferenceIfThenElse.pursnew file+23

@@ -0,0 +1,23 @@

1+-- @inline export fn never

2+module Snapshot.InlineReferenceIfThenElse where

4+fn :: forall r. r -> Int

5+fn _ = 0

7+test1 :: Int

8+test1 = do

9+ let rec = { a: { b: { c: true } }, d: fn {} }

10+ if rec.a.b.c then

11+ 42

12+ else

13+ fn rec

14+

15+extern1 :: { a :: { b :: { c :: Boolean } }, d :: Int }

16+extern1 = { a: { b: { c: true } }, d: fn {} }

17+

18+test2 :: Int

19+test2 =

20+ if extern1.a.b.c then

21+ 42

22+ else

23+ 99

backend-es/test/snapshots/Snapshot.InlineReferenceOpArrayLength.pursnew file+47

@@ -0,0 +1,47 @@

1+-- @inline export fn' never

2+module Snapshot.InlineReferenceOpArrayLength where

4+import Prelude

6+import Data.Array as Array

7+import Data.Maybe (Maybe(..))

9+test1 :: (forall r. r -> Int) -> Array Int

10+test1 fn = do

11+ let array = [ 1, 2, fn {} ]

12+ if Array.length array == 3 then

13+ array

14+ else

15+ []

16+

17+test2 :: (forall r. r -> Int) -> Array (Array Int)

18+test2 fn = do

19+ let array1 = [ 1, 2, fn {} ]

20+ let array2 = [ array1, [ 3, 4 ], [ fn {} ] ]

21+ if Just 3 == (Array.length <$> Array.index array2 0) then

22+ array2

23+ else

24+ [ array1 ] <> array2

25+

26+fn' :: forall r. r -> Int

27+fn' _ = 0

28+

29+extern1 :: Array Int

30+extern1 = [ 1, 2, fn' {} ]

31+

32+extern2 :: Array (Array Int)

33+extern2 = [ extern1, [ 3 ], [ fn' {} ] ]

34+

35+test3 :: Array Int

36+test3 =

37+ if Array.length extern1 == 3 then

38+ extern1

39+ else

40+ []

41+

42+test4 :: Array (Array Int)

43+test4 =

44+ if Just 3 == (Array.length <$> Array.index extern2 0) then

45+ extern2

46+ else

47+ []

backend-es/test/snapshots/Snapshot.InlineReferenceOpIsTag.pursnew file+65

@@ -0,0 +1,65 @@

1+-- @inline export fn' never

2+module Snapshot.InlineReferenceOpIsTag where

4+data List a = Cons a (List a) | Nil

6+test1 :: (forall r. r -> List Int) -> List Int

7+test1 fn = do

8+ let list = Cons 1 (fn {})

9+ case list of

10+ Cons _ _ ->

11+ Cons 0 list

12+ _ ->

13+ Nil

14+

15+test2 :: (forall r. r -> List Int) -> List Int

16+test2 fn = do

17+ let rec = { a: { b: { c: Cons 1 (fn {}) } } }

18+ case rec.a.b.c of

19+ list@(Cons _ _) ->

20+ Cons 0 list

21+ _ ->

22+ fn rec

23+

24+test3 :: (forall r. r -> List Int) -> List Int

25+test3 fn = do

26+ let rec1 = { a: { b: { c: Cons 1 (fn {}) } } }

27+ let rec2 = { d: rec1, e: fn {} }

28+ case rec2.d.a.b.c of

29+ list@(Cons _ _) ->

30+ Cons 0 list

31+ _ ->

32+ fn { rec1, rec2 }

33+

34+fn' :: forall r. r -> List Int

35+fn' _ = Nil

36+

37+extern1 :: List Int

38+extern1 = Cons 1 (fn' {})

39+

40+extern2 :: { a :: { b :: { c :: List Int } } }

41+extern2 = { a: { b: { c: Cons 1 (fn' {}) } } }

42+

43+extern3 :: { d :: { a :: { b :: { c :: List Int } } }, e :: List Int }

44+extern3 = { d: extern2, e: fn' {} }

45+

46+test4 :: List Int

47+test4 = case extern1 of

48+ Cons _ _ ->

49+ Cons 0 extern1

50+ _ ->

51+ Nil

52+

53+test5 :: List Int

54+test5 = case extern2.a.b.c of

55+ list@(Cons _ _) ->

56+ Cons 0 list

57+ _ ->

58+ Nil

59+

60+test6 :: List Int

61+test6 = case extern3.d.a.b.c of

62+ list@(Cons _ _) ->

63+ Cons 0 list

64+ _ ->

65+ Nil

backend-es/test/snapshots/Snapshot.InlineReferencePrimOpBoolean.pursnew file+55

@@ -0,0 +1,55 @@

1+-- @inline export fn never

2+module Snapshot.InlineReferencePrimOpBoolean where

4+import Prelude

6+fn :: forall r. r -> Int

7+fn _ = 0

9+test1 :: Int

10+test1 = do

11+ let rec = { a: { b: { c: true } }, d: fn {}, e: true, f: false }

12+ if rec.a.b.c && rec.e then

13+ 42

14+ else

15+ fn rec

16+

17+test2 :: Int

18+test2 = do

19+ let rec = { a: { b: { c: true } }, d: fn {}, e: true, f: false }

20+ if rec.f || rec.a.b.c then

21+ 42

22+ else

23+ fn rec

24+

25+test3 :: Int

26+test3 = do

27+ let rec = { a: { b: { c: true } }, d: fn {}, e: true, f: false }

28+ if not rec.a.b.c then

29+ fn rec

30+ else

31+ 42

32+

33+extern1 :: { a :: { b :: { c :: Boolean } }, d :: Int, e :: Boolean, f :: Boolean }

34+extern1 = { a: { b: { c: true } }, d: fn {}, e: true, f: false }

35+

36+test4 :: Int

37+test4 =

38+ if extern1.a.b.c && extern1.e then

39+ 42

40+ else

41+ 99

42+

43+test5 :: Int

44+test5 =

45+ if extern1.f || extern1.a.b.c then

46+ 42

47+ else

48+ 99

49+

50+test6 :: Int

51+test6 =

52+ if not extern1.a.b.c then

53+ 99

54+ else

55+ 42

backend-es/test/snapshots/Snapshot.InlineReferencePrimOpInt.pursnew file+51

@@ -0,0 +1,51 @@

1+-- @inline export fn never

2+-- @inline export localTest always

3+-- @inline export externTest always

4+module Snapshot.InlineReferencePrimOpInt where

6+import Prelude

8+fn :: forall r. r -> Int

9+fn _ = 0

10+

11+type Rec = { a :: { b :: { c :: Int } }, d :: Int, e :: Int }

12+

13+localTest :: (Rec -> Int) -> Int

14+localTest f = do

15+ let rec = { a: { b: { c: 99 }}, d: fn {}, e: 11 }

16+ let res = f rec

17+ if res /= bottom then res

18+ else fn rec

19+

20+test1 :: Int

21+test1 = localTest \rec -> rec.a.b.c + rec.e

22+

23+test2 :: Int

24+test2 = localTest \rec -> rec.a.b.c - rec.e

25+

26+test3 :: Int

27+test3 = localTest \rec -> rec.a.b.c * rec.e

28+

29+test4 :: Int

30+test4 = localTest \rec -> rec.a.b.c / rec.e

31+

32+extern :: Rec

33+extern = { a: { b: { c: 99 }}, d: fn {}, e: 11 }

34+

35+externTest :: (Rec -> Int) -> Int

36+externTest f = do

37+ let res = f extern

38+ if res /= bottom then res

39+ else bottom

40+

41+test5 :: Int

42+test5 = externTest \rec -> rec.a.b.c + rec.e

43+

44+test6 :: Int

45+test6 = externTest \rec -> rec.a.b.c - rec.e

46+

47+test7 :: Int

48+test7 = externTest \rec -> rec.a.b.c * rec.e

49+

50+test8 :: Int

51+test8 = externTest \rec -> rec.a.b.c / rec.e

backend-es/test/snapshots/Snapshot.InlineReferencePrimOpNumber.pursnew file+51

@@ -0,0 +1,51 @@

1+-- @inline export fn never

2+-- @inline export localTest always

3+-- @inline export externTest always

4+module Snapshot.InlineReferencePrimOpNumber where

6+import Prelude

8+fn :: forall r. r -> Number

9+fn _ = 0.0

10+

11+type Rec = { a :: { b :: { c :: Number } }, d :: Number, e :: Number }

12+

13+localTest :: (Rec -> Number) -> Number

14+localTest f = do

15+ let rec = { a: { b: { c: 99.0 }}, d: fn {}, e: 11.0 }

16+ let res = f rec

17+ if res /= bottom then res

18+ else fn rec

19+

20+test1 :: Number

21+test1 = localTest \rec -> rec.a.b.c + rec.e

22+

23+test2 :: Number

24+test2 = localTest \rec -> rec.a.b.c - rec.e

25+

26+test3 :: Number

27+test3 = localTest \rec -> rec.a.b.c * rec.e

28+

29+test4 :: Number

30+test4 = localTest \rec -> rec.a.b.c / rec.e

31+

32+extern :: Rec

33+extern = { a: { b: { c: 99.0 }}, d: fn {}, e: 11.0 }

34+

35+externTest :: (Rec -> Number) -> Number

36+externTest f = do

37+ let res = f extern

38+ if res /= bottom then res

39+ else bottom

40+

41+test5 :: Number

42+test5 = externTest \rec -> rec.a.b.c + rec.e

43+

44+test6 :: Number

45+test6 = externTest \rec -> rec.a.b.c - rec.e

46+

47+test7 :: Number

48+test7 = externTest \rec -> rec.a.b.c * rec.e

49+

50+test8 :: Number

51+test8 = externTest \rec -> rec.a.b.c / rec.e

backend-es/test/snapshots/Snapshot.InlineReferenceRecordUpdate.pursnew file+31

@@ -0,0 +1,31 @@

1+-- @inline export fn' never

2+module Snapshot.InlineReferenceRecordUpdate where

4+import Prelude

6+import Unsafe.Coerce (unsafeCoerce)

8+test1 :: (forall r. r -> { a :: Int, b :: Int, c :: Int }) -> Int

9+test1 fn = do

10+ let rec1 = fn {}

11+ let rec2 = rec1 { a = 42, b = fn {} }

12+ if rec2.a == 42 then

13+ rec2.c

14+ else

15+ (fn { rec1, rec2 }).c

16+

17+-- unsafeCoerce is needed to construct the polymorphic tail.

18+-- This is only needed to subvert the compiler's record update

19+-- optimization, which is slated to be removed.

20+fn' :: forall r x. r -> { a :: Int, b :: Int, c :: Int | x }

21+fn' _ = unsafeCoerce { a: 1, b: 2, c: 3 }

22+

23+extern :: forall x. { a :: Int, b :: Int, c :: Int | x }

24+extern = (fn' {}) { a = 42 }

25+

26+test2 :: Int

27+test2 =

28+ if extern.a == 42 then

29+ extern.c

30+ else

31+ 0

backend-es/test/snapshots/Snapshot.PrimOpIntDiv.pursnew file+16

@@ -0,0 +1,16 @@

1+-- @inline export divNoInline never

2+module Snapshot.PrimOpIntDiv where

4+import Prelude

6+import Assert (assertEqual)

7+import Effect (Effect)

9+divNoInline :: Int -> Int -> Int

10+divNoInline a b = a / b -- This needs to stay eta-expanded to test runtime div

11+

12+main :: Effect Unit

13+main = do

14+ assertEqual "div1" { expected: 0, actual: divNoInline 1 0 }

15+ assertEqual "div2" { expected: 1, actual: divNoInline 3 2 }

16+ assertEqual "div3" { expected: -1, actual: divNoInline 3 (-2) }

src/PureScript/Backend/Optimizer/Convert.purs+8−4

@@ -73,7 +73,7 @@ import Partial.Unsafe (unsafeCrashWith, unsafePartial)

7373import PureScript.Backend.Optimizer.Analysis (BackendAnalysis)

7474import PureScript.Backend.Optimizer.CoreFn (Ann(..), Bind(..), Binder(..), Binding(..), CaseAlternative(..), CaseGuard(..), Comment, ConstructorType(..), Expr(..), Guard(..), Ident(..), Literal(..), Meta(..), Module(..), ModuleName(..), ProperName, Qualified(..), ReExport, findProp, propKey, propValue, qualifiedModuleName, unQualified)

7575import PureScript.Backend.Optimizer.Directives (DirectiveHeaderResult, parseDirectiveHeader)

76−import PureScript.Backend.Optimizer.Semantics (BackendExpr(..), BackendSemantics, Ctx, DataTypeMeta, Env(..), EvalRef(..), ExternImpl(..), ExternSpine, InlineAccessor(..), InlineDirective(..), InlineDirectiveMap, NeutralExpr(..), build, evalExternFromImpl, freeze, optimize)

76+import PureScript.Backend.Optimizer.Semantics (BackendExpr(..), BackendSemantics, Ctx, DataTypeMeta, Env(..), EvalRef(..), ExternImpl(..), ExternSpine, InlineAccessor(..), InlineDirective(..), InlineDirectiveMap, NeutralExpr(..), build, evalExternFromImpl, evalExternRefFromImpl, freeze, optimize)

7777import PureScript.Backend.Optimizer.Semantics.Foreign (ForeignEval)

7878import PureScript.Backend.Optimizer.Syntax (BackendAccessor(..), BackendOperator(..), BackendOperator1(..), BackendOperator2(..), BackendOperatorOrd(..), BackendSyntax(..), Level(..), Pair(..))

7979import PureScript.Backend.Optimizer.Utils (foldl1Array)

@@ -243,7 +243,7 @@ type OptimizationSteps = Array (Tuple (Qualified Ident) (NonEmptyArray BackendEx

243243

244244toTopLevelBackendBinding :: Array (Qualified Ident) -> ConvertEnv -> Binding Ann -> Accum ConvertEnv (Tuple Ident (WithDeps NeutralExpr))

245245toTopLevelBackendBinding group env (Binding _ ident cfn) = do

246− let evalEnv = Env { currentModule: env.currentModule, evalExtern: makeExternEval env, locals: [], directives: env.directives }

246+ let evalEnv = Env { currentModule: env.currentModule, evalExternRef: makeExternEvalRef env, evalExternSpine: makeExternEvalSpine env, locals: [], directives: env.directives }

247247 let qualifiedIdent = Qualified (Just env.currentModule) ident

248248 let backendExpr = toBackendExpr cfn env

249249 let enableTracing = Set.member qualifiedIdent env.traceIdents

@@ -336,8 +336,8 @@ toExternImpl env group expr = case expr of

336336topEnv :: Env -> Env

337337topEnv (Env env) = Env env { locals = [] }

338338

339−makeExternEval :: ConvertEnv -> Env -> Qualified Ident -> Array ExternSpine -> Maybe BackendSemantics

340−makeExternEval conv env qual spine = do

339+makeExternEvalSpine :: ConvertEnv -> Env -> Qualified Ident -> Array ExternSpine -> Maybe BackendSemantics

340+makeExternEvalSpine conv env qual spine = do

341341 let

342342 result = do

343343 fn <- Map.lookup qual conv.foreignSemantics

@@ -349,6 +349,10 @@ makeExternEval conv env qual spine = do

349349 _ ->

350350 result

351351

352+makeExternEvalRef :: ConvertEnv -> Env -> Qualified Ident -> Maybe BackendSemantics

353+makeExternEvalRef conv env qual =

354+ evalExternRefFromImpl env qual <$> Map.lookup qual conv.implementations

355+

352356buildM :: BackendSyntax BackendExpr -> ConvertM BackendExpr

353357buildM a env = build (getCtx env) a

354358

src/PureScript/Backend/Optimizer/Semantics.purs+163−89

@@ -35,7 +35,7 @@ data MkFn a

3535 | MkFnNext (Maybe Ident) (a -> MkFn a)

3636

3737data BackendSemantics

38− = SemExtern (Qualified Ident) (Array ExternSpine) (Lazy BackendSemantics)

38+ = SemRef EvalRef (Array ExternSpine) (Lazy BackendSemantics)

3939 | SemLam (Maybe Ident) (BackendSemantics -> BackendSemantics)

4040 | SemMkFn (MkFn BackendSemantics)

4141 | SemMkEffectFn (MkFn BackendSemantics)

@@ -45,7 +45,7 @@ data BackendSemantics

4545 | SemEffectPure BackendSemantics

4646 | SemEffectDefer BackendSemantics

4747 | SemBranch (NonEmptyArray (SemConditional BackendSemantics)) (Lazy BackendSemantics)

48− | NeutLocal (Maybe Ident) Level (Maybe BackendSemantics)

48+ | NeutLocal (Maybe Ident) Level

4949 | NeutVar (Qualified Ident)

5050 | NeutStop (Qualified Ident)

5151 | NeutData (Qualified Ident) ConstructorType ProperName Ident (Array (Tuple String BackendSemantics))

@@ -162,7 +162,8 @@ type InlineDirectiveMap = Map EvalRef (Map InlineAccessor InlineDirective)

162162

163163newtype Env = Env

164164 { currentModule :: ModuleName

165− , evalExtern :: Env -> Qualified Ident -> Array ExternSpine -> Maybe BackendSemantics

165+ , evalExternRef :: Env -> Qualified Ident -> Maybe BackendSemantics

166+ , evalExternSpine :: Env -> Qualified Ident -> Array ExternSpine -> Maybe BackendSemantics

166167 , locals :: Array (LocalBinding BackendSemantics)

167168 , directives :: InlineDirectiveMap

168169 }

@@ -200,9 +201,18 @@ class Eval f where

200201 eval :: Env -> f -> BackendSemantics

201202

202203instance Eval f => Eval (BackendSyntax f) where

203− eval env = case _ of

204+ eval env@(Env e) = case _ of

204205 Var qual ->

205− evalExtern env qual []

206+ case e.evalExternSpine env qual [] of

207+ Just sem ->

208+ sem

209+ Nothing ->

210+ SemRef (EvalExtern qual) [] $ defer \_ ->

211+ case e.evalExternRef env qual of

212+ Just sem ->

213+ deref sem

214+ Nothing ->

215+ NeutVar qual

206216 Local ident lvl ->

207217 case lookupLocal env lvl of

208218 Just (One sem) -> sem

@@ -391,8 +401,8 @@ evalApp env hd spine = go env hd (List.fromFoldable spine)

391401 SemLam _ k, List.Cons arg args ->

392402 makeLet Nothing arg \nextArg ->

393403 go env' (k nextArg) args

394− SemExtern qual sp _, List.Cons arg args -> do

395− go env' (evalExtern env' qual (snocApp sp arg)) args

404+ SemRef ref sp sem, List.Cons arg args ->

405+ go env' (evalRef env' ref sp (ExternApp [ arg ]) sem) args

396406 SemLet ident val k, args ->

397407 SemLet ident val \nextVal ->

398408 makeLet Nothing (k nextVal) \nextFn ->

@@ -410,9 +420,9 @@ evalUncurriedApp :: Env -> BackendSemantics -> Spine BackendSemantics -> Backend

410420evalUncurriedApp env hd spine = case hd of

411421 SemMkFn mk ->

412422 evalUncurriedBeta NeutUncurriedApp mk spine

413− SemExtern qual sp _ ->

423+ SemRef ref sp sem ->

414424 guardFailOver identity spine \spine' ->

415− evalExtern env qual (Array.snoc sp (ExternUncurriedApp spine'))

425+ evalRef env ref sp (ExternUncurriedApp spine') sem

416426 SemLet ident val k ->

417427 SemLet ident val \nextVal ->

418428 makeLet Nothing (k nextVal) \nextFn ->

@@ -490,8 +500,8 @@ neutralApp hd spine

490500evalAccessor :: Env -> BackendSemantics -> BackendAccessor -> BackendSemantics

491501evalAccessor initEnv initLhs accessor =

492502 evalAssocLet initEnv initLhs \env lhs -> case lhs of

493− SemExtern qual spine _ ->

494− evalExtern env qual $ Array.snoc spine (ExternAccessor accessor)

503+ SemRef ref spine sem ->

504+ evalRef env ref spine (ExternAccessor accessor) sem

495505 NeutLit (LitRecord props)

496506 | GetProp prop <- accessor

497507 , Just sem <- Array.findMap (\(Prop p v) -> guard (p == prop) $> v) props ->

@@ -532,7 +542,7 @@ evalBranches _ initConds initDef = go [] (NonEmptyArray.toArray initConds) initD

532542 go acc conds def = case Array.uncons conds of

533543 Just { head, tail } ->

534544 case head of

535− SemConditional c t -> case force c of

545+ SemConditional c t -> case deref (force c) of

536546 NeutLit (LitBoolean didMatch)

537547 | didMatch -> go acc [] t

538548 | otherwise -> go acc tail def

@@ -591,9 +601,9 @@ evalAssocLet2 env sem1 sem2 go =

591601

592602makeLet :: Maybe Ident -> BackendSemantics -> (BackendSemantics -> BackendSemantics) -> BackendSemantics

593603makeLet ident binding go = case binding of

594− SemExtern _ [] _ ->

604+ SemRef _ [] _ ->

595605 go binding

596− NeutLocal _ _ _ ->

606+ NeutLocal _ _ ->

597607 go binding

598608 NeutStop _ ->

599609 go binding

@@ -604,33 +614,38 @@ makeLet ident binding go = case binding of

604614

605615deref :: BackendSemantics -> BackendSemantics

606616deref = case _ of

607− NeutLocal _ _ (Just expr) -> expr

608− expr -> expr

617+ SemRef _ _ sem ->

618+ force sem

619+ sem ->

620+ sem

609621

610−-- TODO: Check for overflow in Int ops since backends may not handle it the

611−-- same was as the JS backend.

612622evalPrimOp :: Env -> BackendOperator BackendSemantics -> BackendSemantics

613623evalPrimOp env = case _ of

614624 Op1 op1 x ->

615625 case op1, x of

616− OpBooleanNot, NeutLit (LitBoolean bool) ->

617− liftBoolean (not bool)

618− OpBooleanNot, NeutPrimOp op ->

619− evalPrimOpNot op

620− OpIntBitNot, NeutLit (LitInt a) ->

621− liftInt (complement a)

626+ OpBooleanNot, _

627+ | NeutLit (LitBoolean bool) <- deref x ->

628+ liftBoolean (not bool)

629+ OpBooleanNot, _

630+ | NeutPrimOp op <- deref x ->

631+ evalPrimOpNot op

632+ OpIntBitNot, _

633+ | NeutLit (LitInt a) <- deref x ->

634+ liftInt (complement a)

622635 OpIsTag a, _

623636 | NeutData b _ _ _ _ <- deref x ->

624637 liftBoolean (a == b)

625638 OpArrayLength, _

626639 | NeutLit (LitArray arr) <- deref x ->

627640 liftInt (Array.length arr)

628− OpIntNegate, NeutLit (LitInt a) ->

629− liftInt (negate a)

630− OpNumberNegate, NeutLit (LitNumber a) ->

631− liftNumber (negate a)

632− _, SemExtern qual spine _ ->

633− evalExtern env qual $ Array.snoc spine (ExternPrimOp op1)

641+ OpIntNegate, _

642+ | NeutLit (LitInt a) <- deref x ->

643+ liftInt (negate a)

644+ OpNumberNegate, _

645+ | NeutLit (LitNumber a) <- deref x ->

646+ liftNumber (negate a)

647+ _, SemRef ref spine sem ->

648+ evalRef env ref spine (ExternPrimOp op1) sem

634649 _, NeutFail err ->

635650 NeutFail err

636651 _, _ ->

@@ -639,83 +654,83 @@ evalPrimOp env = case _ of

639654 Op2 op2 x y ->

640655 case op2 of

641656 OpBooleanAnd

642− | NeutLit (LitBoolean false) <- x ->

657+ | NeutLit (LitBoolean false) <- deref x ->

643658 x

644− | NeutLit (LitBoolean false) <- y ->

659+ | NeutLit (LitBoolean false) <- deref y ->

645660 y

646− | NeutLit (LitBoolean true) <- x ->

661+ | NeutLit (LitBoolean true) <- deref x ->

647662 y

648− | NeutLit (LitBoolean true) <- y ->

663+ | NeutLit (LitBoolean true) <- deref y ->

649664 x

650665 OpBooleanOr

651− | NeutLit (LitBoolean false) <- x ->

666+ | NeutLit (LitBoolean false) <- deref x ->

652667 y

653− | NeutLit (LitBoolean false) <- y ->

668+ | NeutLit (LitBoolean false) <- deref y ->

654669 x

655− | NeutLit (LitBoolean true) <- x ->

670+ | NeutLit (LitBoolean true) <- deref x ->

656671 x

657− | NeutLit (LitBoolean true) <- y ->

672+ | NeutLit (LitBoolean true) <- deref y ->

658673 y

659674 OpBooleanOrd OpEq

660− | NeutLit (LitBoolean bool) <- x ->

675+ | NeutLit (LitBoolean bool) <- deref x ->

661676 if bool then y else evalPrimOp env (Op1 OpBooleanNot y)

662− | NeutLit (LitBoolean bool) <- y ->

677+ | NeutLit (LitBoolean bool) <- deref y ->

663678 if bool then x else evalPrimOp env (Op1 OpBooleanNot x)

664679 OpBooleanOrd op

665− | NeutLit (LitBoolean a) <- x

666− , NeutLit (LitBoolean b) <- y ->

680+ | NeutLit (LitBoolean a) <- deref x

681+ , NeutLit (LitBoolean b) <- deref y ->

667682 liftBoolean (evalPrimOpOrd op a b)

668683 OpCharOrd op

669− | NeutLit (LitChar a) <- x

670− , NeutLit (LitChar b) <- y ->

684+ | NeutLit (LitChar a) <- deref x

685+ , NeutLit (LitChar b) <- deref y ->

671686 liftBoolean (evalPrimOpOrd op a b)

672687 OpIntBitAnd

673− | NeutLit (LitInt a) <- x

674− , NeutLit (LitInt b) <- y ->

688+ | NeutLit (LitInt a) <- deref x

689+ , NeutLit (LitInt b) <- deref y ->

675690 liftInt (a .&. b)

676691 OpIntBitOr

677− | NeutLit (LitInt a) <- x

678− , NeutLit (LitInt b) <- y ->

692+ | NeutLit (LitInt a) <- deref x

693+ , NeutLit (LitInt b) <- deref y ->

679694 liftInt (a .|. b)

680695 OpIntBitShiftLeft

681− | NeutLit (LitInt a) <- x

682− , NeutLit (LitInt b) <- y ->

696+ | NeutLit (LitInt a) <- deref x

697+ , NeutLit (LitInt b) <- deref y ->

683698 liftInt (shl a b)

684699 OpIntBitShiftRight

685− | NeutLit (LitInt a) <- x

686− , NeutLit (LitInt b) <- y ->

700+ | NeutLit (LitInt a) <- deref x

701+ , NeutLit (LitInt b) <- deref y ->

687702 liftInt (shr a b)

688703 OpIntBitXor

689− | NeutLit (LitInt a) <- x

690− , NeutLit (LitInt b) <- y ->

704+ | NeutLit (LitInt a) <- deref x

705+ , NeutLit (LitInt b) <- deref y ->

691706 liftInt (xor a b)

692707 OpIntBitZeroFillShiftRight

693− | NeutLit (LitInt a) <- x

694− , NeutLit (LitInt b) <- y ->

708+ | NeutLit (LitInt a) <- deref x

709+ , NeutLit (LitInt b) <- deref y ->

695710 liftInt (zshr a b)

696711 OpIntNum OpSubtract

697− | NeutLit (LitInt 0) <- x ->

712+ | NeutLit (LitInt 0) <- deref x ->

698713 evalPrimOp env (Op1 OpIntNegate y)

699714 OpIntNum op

700715 | Just result <- evalPrimOpNumInt op x y ->

701716 result

702717 OpIntOrd op

703− | NeutLit (LitInt a) <- x

704− , NeutLit (LitInt b) <- y ->

718+ | NeutLit (LitInt a) <- deref x

719+ , NeutLit (LitInt b) <- deref y ->

705720 liftBoolean (evalPrimOpOrd op a b)

706721 OpNumberNum OpSubtract

707− | NeutLit (LitNumber 0.0) <- x ->

722+ | NeutLit (LitNumber 0.0) <- deref x ->

708723 evalPrimOp env (Op1 OpNumberNegate y)

709724 OpNumberNum op

710725 | Just result <- evalPrimOpNumNumber op x y ->

711726 result

712727 OpNumberOrd op

713− | NeutLit (LitNumber a) <- x

714− , NeutLit (LitNumber b) <- y ->

728+ | NeutLit (LitNumber a) <- deref x

729+ , NeutLit (LitNumber b) <- deref y ->

715730 liftBoolean (evalPrimOpOrdNumber op a b)

716731 OpStringOrd op

717− | NeutLit (LitString a) <- x

718− , NeutLit (LitString b) <- y ->

732+ | NeutLit (LitString a) <- deref x

733+ , NeutLit (LitString b) <- deref y ->

719734 liftBoolean (evalPrimOpOrd op a b)

720735 OpStringAppend

721736 | Just result <- evalPrimOpAssocL OpStringAppend caseString (\a b -> Just $ liftString (a <> b)) x y ->

@@ -802,16 +817,16 @@ evalPrimOpOrdNumber op x y = case op of

802817evalPrimOpNumNumber :: BackendOperatorNum -> BackendSemantics -> BackendSemantics -> Maybe BackendSemantics

803818evalPrimOpNumNumber op x y = case op of

804819 OpAdd ->

805− evalPrimOpAssocL (OpNumberNum OpAdd) caseNumber (\a b -> Just $ liftNumber (a + b)) x y

820+ evalPrimOpAssocL (OpNumberNum OpAdd) (caseNumber <<< deref) (\a b -> Just $ liftNumber (a + b)) x y

806821 OpMultiply ->

807− evalPrimOpAssocL (OpNumberNum OpMultiply) caseNumber (\a b -> Just $ liftNumber (a * b)) x y

822+ evalPrimOpAssocL (OpNumberNum OpMultiply) (caseNumber <<< deref) (\a b -> Just $ liftNumber (a * b)) x y

808823 OpSubtract

809− | NeutLit (LitNumber a) <- x

810− , NeutLit (LitNumber b) <- y ->

824+ | NeutLit (LitNumber a) <- deref x

825+ , NeutLit (LitNumber b) <- deref y ->

811826 Just $ liftNumber (a - b)

812827 OpDivide

813− | NeutLit (LitNumber a) <- x

814− , NeutLit (LitNumber b) <- y ->

828+ | NeutLit (LitNumber a) <- deref x

829+ , NeutLit (LitNumber b) <- deref y ->

815830 Just $ liftNumber (a / b)

816831 _ ->

817832 Nothing

@@ -819,7 +834,7 @@ evalPrimOpNumNumber op x y = case op of

819834evalPrimOpNumInt :: BackendOperatorNum -> BackendSemantics -> BackendSemantics -> Maybe BackendSemantics

820835evalPrimOpNumInt op x y = case op of

821836 OpAdd ->

822− evalPrimOpAssocL (OpIntNum OpAdd) caseInt addOverflow x y

837+ evalPrimOpAssocL (OpIntNum OpAdd) (caseInt <<< deref) addOverflow x y

823838 where

824839 addOverflow a b = do

825840 let res = a + b

@@ -828,7 +843,7 @@ evalPrimOpNumInt op x y = case op of

828843 else

829844 Just $ liftInt res

830845 OpMultiply ->

831− evalPrimOpAssocL (OpIntNum OpMultiply) caseInt mulOverflow x y

846+ evalPrimOpAssocL (OpIntNum OpMultiply) (caseInt <<< deref) mulOverflow x y

832847 where

833848 mulOverflow a b = do

834849 let res = a * b

@@ -837,16 +852,16 @@ evalPrimOpNumInt op x y = case op of

837852 else

838853 Just $ liftInt res

839854 OpSubtract

840− | NeutLit (LitInt a) <- x

841− , NeutLit (LitInt b) <- y -> do

855+ | NeutLit (LitInt a) <- deref x

856+ , NeutLit (LitInt b) <- deref y -> do

842857 let res = a - b

843858 if b > 0 && res > a || b < 0 && res < a then

844859 Nothing

845860 else

846861 Just $ liftInt res

847862 OpDivide

848− | NeutLit (LitInt a) <- x

849− , NeutLit (LitInt b) <- y ->

863+ | NeutLit (LitInt a) <- deref x

864+ , NeutLit (LitInt b) <- deref y ->

850865 Just $ liftInt (a / b)

851866 _ ->

852867 Nothing

@@ -883,10 +898,41 @@ primOpOrdNot = case _ of

883898 OpGt -> OpLte

884899 OpGte -> OpLt

885900

886−evalExtern :: Env -> Qualified Ident -> Array ExternSpine -> BackendSemantics

887−evalExtern env@(Env e) qual spine = case e.evalExtern env qual spine of

888− Nothing -> SemExtern qual spine (defer \_ -> neutralSpine (NeutVar qual) spine)

889− Just sem -> sem

901+evalRef :: Env -> EvalRef -> Array ExternSpine -> ExternSpine -> Lazy BackendSemantics -> BackendSemantics

902+evalRef env@(Env e) ref spine last sem = case ref of

903+ EvalExtern qual

904+ | Just sem' <- e.evalExternSpine env qual spine' ->

905+ sem'

906+ _ ->

907+ SemRef ref spine' $ defer \_ ->

908+ deref $ evalRefSpine env ref spine' sem last

909+ where

910+ spine' = snocSpine spine last

911+

912+evalRefSpine :: Env -> EvalRef -> Array ExternSpine -> Lazy BackendSemantics -> ExternSpine -> BackendSemantics

913+evalRefSpine env ref spine sem = case _ of

914+ ExternApp _ ->

915+ neutralSpine (evalEvalRef ref) spine

916+ ExternUncurriedApp _ ->

917+ neutralSpine (evalEvalRef ref) spine

918+ ExternAccessor acc ->

919+ evalAccessor env (force sem) acc

920+ ExternPrimOp op ->

921+ evalPrimOp env (Op1 op (force sem))

922+

923+evalEvalRef :: EvalRef -> BackendSemantics

924+evalEvalRef = case _ of

925+ EvalExtern qual ->

926+ NeutVar qual

927+ EvalLocal ident lvl ->

928+ NeutLocal ident lvl

929+

930+snocSpine :: Array ExternSpine -> ExternSpine -> Array ExternSpine

931+snocSpine spine = case _ of

932+ ExternApp apps ->

933+ foldl snocApp spine apps

934+ other ->

935+ Array.snoc spine other

890936

891937envForGroup :: Env -> EvalRef -> InlineAccessor -> Array (Qualified Ident) -> Env

892938envForGroup env ref acc group

@@ -1031,6 +1077,30 @@ evalExternFromImpl env@(Env e) qual (Tuple analysis impl) spine = case spine of

10311077 _ ->

10321078 Nothing

10331079

1080+evalExternRefFromImpl :: Env -> Qualified Ident -> Tuple BackendAnalysis ExternImpl -> BackendSemantics

1081+evalExternRefFromImpl env qual (Tuple _ impl) = case impl of

1082+ ExternExpr group (NeutralExpr expr)

1083+ | isRefExpr expr ->

1084+ eval (envForGroup env (EvalExtern qual) InlineRef group) expr

1085+ ExternDict group props ->

1086+ NeutLit $ LitRecord $ map

1087+ ( \(Prop prop (Tuple _ (NeutralExpr expr))) ->

1088+ Prop prop $ eval (envForGroup env (EvalExtern qual) (InlineProp prop) group) expr

1089+ )

1090+ props

1091+ _ ->

1092+ NeutVar qual

1093+

1094+isRefExpr :: forall a. BackendSyntax a -> Boolean

1095+isRefExpr = case _ of

1096+ Var _ -> true

1097+ Lit _ -> true

1098+ CtorSaturated _ _ _ _ _ -> true

1099+ Accessor _ _ -> true

1100+ Update _ _ -> true

1101+ PrimOp _ -> true

1102+ _ -> false

1103+

10341104analysisFromDirective :: BackendAnalysis -> InlineDirective -> BackendAnalysis

10351105analysisFromDirective (BackendAnalysis analysis) = case _ of

10361106 InlineAlways ->

@@ -1091,21 +1161,21 @@ quote = go

10911161 -- Block constructors

10921162 SemLet ident binding k -> do

10931163 let Tuple level ctx' = nextLevel ctx

1094− build ctx $ Let ident level (quote (ctx { effect = false }) binding) $ quote ctx' $ k $ NeutLocal ident level (Just binding)

1164+ build ctx $ Let ident level (quote (ctx { effect = false }) binding) $ quote ctx' $ k $ SemRef (EvalLocal ident level) [] $ defer \_ -> deref binding

10951165 SemLetRec bindings k -> do

10961166 let Tuple level ctx' = nextLevel ctx

10971167 -- We are not currently propagating references

10981168 -- to recursive bindings. The language requires

10991169 -- a runtime check for strictly recursive bindings

11001170 -- which we don't currently implement.

1101− let neutBindings = (\(Tuple ident _) -> Tuple ident $ defer \_ -> NeutLocal (Just ident) level Nothing) <$> bindings

1171+ let neutBindings = (\(Tuple ident _) -> Tuple ident $ defer \_ -> NeutLocal (Just ident) level) <$> bindings

11021172 build ctx $ LetRec level

11031173 (map (\b -> quote (ctx' { effect = false }) $ b neutBindings) <$> bindings)

11041174 (quote ctx' $ k neutBindings)

11051175 SemEffectBind ident binding k -> do

11061176 let ctx' = ctx { effect = true }

11071177 let Tuple level ctx'' = nextLevel ctx'

1108− build ctx $ EffectBind ident level (quote ctx' binding) $ quote ctx'' $ k $ NeutLocal ident level (Just binding)

1178+ build ctx $ EffectBind ident level (quote ctx' binding) $ quote ctx'' $ k $ NeutLocal ident level

11091179 SemEffectPure sem ->

11101180 build ctx $ EffectPure (quote (ctx { effect = false }) sem)

11111181 SemEffectDefer sem ->

@@ -1117,17 +1187,21 @@ quote = go

11171187 foldr (buildBranchCond ctx) (quote ctx <<< force $ def) branches'

11181188

11191189 -- Non-block constructors

1120− SemExtern _ _ sem ->

1121− go ctx (force sem)

1190+ SemRef ref sp _ ->

1191+ case ref of

1192+ EvalExtern qual ->

1193+ go ctx $ neutralSpine (NeutVar qual) sp

1194+ EvalLocal ident lvl ->

1195+ go ctx $ neutralSpine (NeutLocal ident lvl) sp

11221196 SemLam ident k -> do

11231197 let Tuple level ctx' = nextLevel ctx

1124− build ctx $ Abs (NonEmptyArray.singleton (Tuple ident level)) $ quote (ctx' { effect = false }) $ k $ NeutLocal ident level Nothing

1198+ build ctx $ Abs (NonEmptyArray.singleton (Tuple ident level)) $ quote (ctx' { effect = false }) $ k $ NeutLocal ident level

11251199 SemMkFn pro -> do

11261200 let

11271201 loop ctx' idents = case _ of

11281202 MkFnNext ident k -> do

11291203 let Tuple lvl ctx'' = nextLevel ctx'

1130− loop ctx'' (Array.snoc idents (Tuple ident lvl)) (k (NeutLocal ident lvl Nothing))

1204+ loop ctx'' (Array.snoc idents (Tuple ident lvl)) (k (NeutLocal ident lvl))

11311205 MkFnApplied body ->

11321206 build ctx' $ UncurriedAbs idents $ quote (ctx' { effect = false }) body

11331207 loop ctx [] pro

@@ -1136,11 +1210,11 @@ quote = go

11361210 loop ctx' idents = case _ of

11371211 MkFnNext ident k -> do

11381212 let Tuple lvl ctx'' = nextLevel ctx'

1139− loop ctx'' (Array.snoc idents (Tuple ident lvl)) (k (NeutLocal ident lvl Nothing))

1213+ loop ctx'' (Array.snoc idents (Tuple ident lvl)) (k (NeutLocal ident lvl))

11401214 MkFnApplied body ->

11411215 build ctx' $ UncurriedEffectAbs idents $ quote (ctx' { effect = false }) body

11421216 loop ctx [] pro

1143− NeutLocal ident level _ ->

1217+ NeutLocal ident level ->

11441218 build ctx $ Local ident level

11451219 NeutVar qual ->

11461220 build ctx $ Var qual

src/PureScript/Backend/Optimizer/Semantics/Foreign.purs+18−30

@@ -5,7 +5,7 @@ import Prelude

55import Data.Array as Array

66import Data.Array.NonEmpty as NonEmptyArray

77import Data.Enum (fromEnum)

8−import Data.Lazy as Lazy

8+import Data.Lazy (defer)

99import Data.List as List

1010import Data.Map (Map)

1111import Data.Map as Map

@@ -13,7 +13,7 @@ import Data.Maybe (Maybe(..))

1313import Data.String as String

1414import Data.Tuple (Tuple(..))

1515import PureScript.Backend.Optimizer.CoreFn (Ident(..), Literal(..), ModuleName(..), Prop(..), Qualified(..), propKey)

16−import PureScript.Backend.Optimizer.Semantics (BackendSemantics(..), Env, ExternSpine(..), evalAccessor, evalApp, evalMkFn, evalPrimOp, evalUncurriedApp, evalUncurriedEffectApp, evalUpdate, liftBoolean, makeLet)

16+import PureScript.Backend.Optimizer.Semantics (BackendSemantics(..), Env, EvalRef(..), ExternSpine(..), evalAccessor, evalApp, evalMkFn, evalPrimOp, evalUncurriedApp, evalUncurriedEffectApp, evalUpdate, liftBoolean, makeLet)

1717import PureScript.Backend.Optimizer.Syntax (BackendAccessor(..), BackendEffect(..), BackendOperator(..), BackendOperator1(..), BackendOperator2(..), BackendOperatorNum(..), BackendOperatorOrd(..))

1818

1919type ForeignEval =

@@ -44,10 +44,10 @@ coreForeignSemantics = Map.fromFoldable semantics

4444 , data_eq_eqIntImpl

4545 , data_eq_eqNumberImpl

4646 , data_eq_eqStringImpl

47+ , data_euclideanRing_intDiv

4748 , data_euclideanRing_numDiv

4849 , data_heytingAlgebra_boolConj

4950 , data_heytingAlgebra_boolDisj

50− , data_heytingAlgebra_boolImplies

5151 , data_heytingAlgebra_boolNot

5252 , data_int_bits_and

5353 , data_int_bits_complement

@@ -211,6 +211,9 @@ data_ring_intSub = Tuple (qualified "Data.Ring" "intSub") $ primBinaryOperator (

211211data_ring_numSub :: ForeignSemantics

212212data_ring_numSub = Tuple (qualified "Data.Ring" "numSub") $ primBinaryOperator (OpNumberNum OpSubtract)

213213

214+data_euclideanRing_intDiv :: ForeignSemantics

215+data_euclideanRing_intDiv = Tuple (qualified "Data.EuclideanRing" "intDiv") $ primBinaryOperator (OpIntNum OpDivide)

216+

214217data_euclideanRing_numDiv :: ForeignSemantics

215218data_euclideanRing_numDiv = Tuple (qualified "Data.EuclideanRing" "numDiv") $ primBinaryOperator (OpNumberNum OpDivide)

216219

@@ -309,21 +312,6 @@ data_heytingAlgebra_boolDisj = Tuple (qualified "Data.HeytingAlgebra" "boolDisj"

309312data_heytingAlgebra_boolNot :: ForeignSemantics

310313data_heytingAlgebra_boolNot = Tuple (qualified "Data.HeytingAlgebra" "boolNot") $ primUnaryOperator OpBooleanNot

311314

312−data_heytingAlgebra_boolImplies :: ForeignSemantics

313−data_heytingAlgebra_boolImplies = Tuple (qualified "Data.HeytingAlgebra" "boolImplies") go

314− where

315− go _ _ = case _ of

316− [ ExternApp [ a, b ] ]

317− | NeutLit (LitBoolean false) <- a ->

318− Just $ NeutLit (LitBoolean true)

319− | NeutLit (LitBoolean true) <- b ->

320− Just $ NeutLit (LitBoolean true)

321− | NeutLit (LitBoolean x) <- a

322− , NeutLit (LitBoolean y) <- b ->

323− Just $ NeutLit (LitBoolean (not x || y))

324− _ ->

325− Nothing

326−

327315data_string_codePoints_toCodePointArray :: ForeignSemantics

328316data_string_codePoints_toCodePointArray = Tuple (qualified "Data.String.CodePoints" "toCodePointArray") go

329317 where

@@ -464,18 +452,18 @@ assocBinaryOperatorL match op def env ident = case _ of

464452 Just $ op env lhs rhs

465453 Nothing ->

466454 case b of

467− SemExtern ident' [ ExternApp [ x, y ] ] _ | ident == ident' ->

455+ SemRef (EvalExtern ident') [ ExternApp [ x, y ] ] _ | ident == ident' ->

468456 case match x of

469457 Just rhs -> do

470458 let result = op env lhs rhs

471− Just $ externApp ident [ result, y ]

459+ Just $ externApp env ident [ result, y ]

472460 Nothing ->

473461 case x of

474− SemExtern ident'' [ ExternApp [ v, w ] ] _ | ident == ident'' ->

462+ SemRef (EvalExtern ident'') [ ExternApp [ v, w ] ] _ | ident == ident'' ->

475463 case match v of

476464 Just rhs -> do

477465 let result = op env lhs rhs

478− Just $ externApp ident [ externApp ident [ result, w ], y ]

466+ Just $ externApp env ident [ externApp env ident [ result, w ], y ]

479467 Nothing ->

480468 Nothing

481469 _ ->

@@ -486,18 +474,18 @@ assocBinaryOperatorL match op def env ident = case _ of

486474 case match b of

487475 Just rhs ->

488476 case a of

489− SemExtern ident' [ ExternApp [ v, w ] ] _ | ident == ident' ->

477+ SemRef (EvalExtern ident') [ ExternApp [ v, w ] ] _ | ident == ident' ->

490478 case match w of

491479 Just lhs -> do

492480 let result = op env lhs rhs

493− Just $ externApp ident [ v, result ]

481+ Just $ externApp env ident [ v, result ]

494482 Nothing ->

495483 case w of

496− SemExtern ident'' [ ExternApp [ x, y ] ] _ | ident == ident'' ->

484+ SemRef (EvalExtern ident'') [ ExternApp [ x, y ] ] _ | ident == ident'' ->

497485 case match y of

498486 Just lhs -> do

499487 let result = op env lhs rhs

500− Just $ externApp ident [ externApp ident [ v, x ], result ]

488+ Just $ externApp env ident [ externApp env ident [ v, x ], result ]

501489 Nothing ->

502490 Nothing

503491 _ ->

@@ -525,8 +513,8 @@ data_semigroup_concatArray = Tuple (qualified "Data.Semigroup" "concatArray") $

525513data_semigroup_concatString :: ForeignSemantics

526514data_semigroup_concatString = Tuple (qualified "Data.Semigroup" "concatString") $ primBinaryOperator OpStringAppend

527515

528−externApp :: Qualified Ident -> Array BackendSemantics -> BackendSemantics

529−externApp ident spine = SemExtern ident [ ExternApp spine ] (Lazy.defer \_ -> NeutApp (NeutVar ident) spine)

516+externApp :: Env -> Qualified Ident -> Array BackendSemantics -> BackendSemantics

517+externApp env qual = evalApp env (SemRef (EvalExtern qual) [] (defer \_ -> NeutVar qual))

530518

531519partial_unsafe_unsafePartial :: ForeignSemantics

532520partial_unsafe_unsafePartial = Tuple (qualified "Partial.Unsafe" "_unsafePartial") go

@@ -585,7 +573,7 @@ record_builder_unsafeModify = Tuple (qualified "Record.Builder" "unsafeModify")

585573 )

586574 props

587575 Just $ NeutLit (LitRecord props')

588− [ ExternApp [ NeutLit (LitString prop), fn, r@(NeutUpdate r'@(NeutLocal _ _ _) _) ] ] -> do

576+ [ ExternApp [ NeutLit (LitString prop), fn, r@(NeutUpdate r'@(NeutLocal _ _) _) ] ] -> do

589577 let update = Prop prop (evalApp env fn [ (evalAccessor env r' (GetProp prop)) ])

590578 Just $ evalUpdate env r [ update ]

591579 [ ExternApp [ NeutLit (LitString prop), fn, other ] ] | Just r <- viewCopyRecord other ->

@@ -597,7 +585,7 @@ record_builder_unsafeModify = Tuple (qualified "Record.Builder" "unsafeModify")

597585

598586viewCopyRecord :: BackendSemantics -> Maybe BackendSemantics

599587viewCopyRecord = case _ of

600− SemExtern (Qualified (Just (ModuleName "Record.Builder")) (Ident "copyRecord")) [ ExternApp [ value ] ] _ ->

588+ SemRef (EvalExtern (Qualified (Just (ModuleName "Record.Builder")) (Ident "copyRecord"))) [ ExternApp [ value ] ] _ ->

601589 Just value

602590 _ ->

603591 Nothing