16aaca6 · rowtype-yoga/purescript-backend-optimizer

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

on main help sign in

Adds deref operation for NeutLocals in the Array.length PrimOp (#64)

16aaca6Mike Solomon3 years ago

backend-es/test/snapshots-out/Snapshot.InlineLocalReferenceOpArrayLength.jsnew file+2

compare with main

unifiedsplit

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

1+const test = fn => [];

2+export {test};

backend-es/test/snapshots-out/Snapshot.InlineLocalReferenceOpIsTag.jsnew file+5

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

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/Snapshot.InlineLocalReferenceOpArrayLength.pursnew file+19

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

1+module Snapshot.InlineLocalReferenceOpArrayLength where

3+import Prelude

5+import Data.Array as Array

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.pursnew file+12

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

1+module Snapshot.InlineLocalReferenceOpIsTag where

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

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

src/PureScript/Backend/Optimizer/Semantics.purs+24−13

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

45 | SemEffectPure BackendSemantics

46 | SemEffectDefer BackendSemantics

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

48− | NeutLocal (Maybe Ident) Level

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

49 | NeutVar (Qualified Ident)

50 | NeutStop (Qualified Ident)

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

@@ -583,7 +583,7 @@ makeLet :: Maybe Ident -> BackendSemantics -> (BackendSemantics -> BackendSemant

583makeLet ident binding go = case binding of

584 SemExtern _ [] _ ->

585 go binding

586− NeutLocal _ _ ->

586+ NeutLocal _ _ _ ->

587 go binding

588 NeutStop _ ->

589 go binding

@@ -592,6 +592,11 @@ makeLet ident binding go = case binding of

592 _ ->

593 SemLet ident binding go

594

595+deref :: BackendSemantics -> BackendSemantics

596+deref = case _ of

597+ NeutLocal _ _ (Just expr) -> expr

598+ expr -> expr

599+

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

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

596-- same was as the JS backend.

601-- same was as the JS backend.

597evalPrimOp :: Env -> BackendOperator BackendSemantics -> BackendSemantics

602evalPrimOp :: Env -> BackendOperator BackendSemantics -> BackendSemantics

@@ -604,10 +609,12 @@ evalPrimOp env = case _ of

604 evalPrimOpNot op

609 evalPrimOpNot op

605 OpIntBitNot, NeutLit (LitInt a) ->

610 OpIntBitNot, NeutLit (LitInt a) ->

606 liftInt (complement a)

611 liftInt (complement a)

612+ OpIsTag a, _

607− OpIsTag a, NeutData b _ _ _ _ ->

613+ | NeutData b _ _ _ _ <- deref x ->

608− liftBoolean (a == b)

614+ liftBoolean (a == b)

615+ OpArrayLength, _

609− OpArrayLength, NeutLit (LitArray arr) ->

616+ | NeutLit (LitArray arr) <- deref x ->

610− liftInt (Array.length arr)

617+ liftInt (Array.length arr)

611 OpIntNegate, NeutLit (LitInt a) ->

618 OpIntNegate, NeutLit (LitInt a) ->

612 liftInt (negate a)

619 liftInt (negate a)

613 OpNumberNegate, NeutLit (LitNumber a) ->

620 OpNumberNegate, NeutLit (LitNumber a) ->

@@ -1034,17 +1041,21 @@ quote = go

1034 -- Block constructors

1041 -- Block constructors

1035 SemLet ident binding k -> do

1042 SemLet ident binding k -> do

1036 let Tuple level ctx' = nextLevel ctx

1043 let Tuple level ctx' = nextLevel ctx

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

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

1038 SemLetRec bindings k -> do

1045 SemLetRec bindings k -> do

1039 let Tuple level ctx' = nextLevel ctx

1046 let Tuple level ctx' = nextLevel ctx

1047+ -- We are not currently propagating references

1048+ -- to recursive bindings. The language requires

1049+ -- a runtime check for strictly recursive bindings

1050+ -- which we don't currently implement.

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

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

1041 build ctx $ LetRec level

1052 build ctx $ LetRec level

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

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

1043 (quote ctx' $ k neutBindings)

1054 (quote ctx' $ k neutBindings)

1044 SemEffectBind ident binding k -> do

1055 SemEffectBind ident binding k -> do

1045 let ctx' = ctx { effect = true }

1056 let ctx' = ctx { effect = true }

1046 let Tuple level ctx'' = nextLevel ctx'

1057 let Tuple level ctx'' = nextLevel ctx'

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

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

1048 SemEffectPure sem ->

1059 SemEffectPure sem ->

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

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

1050 SemEffectDefer sem ->

1061 SemEffectDefer sem ->

@@ -1060,13 +1071,13 @@ quote = go

1060 go ctx (force sem)

1071 go ctx (force sem)

1061 SemLam ident k -> do

1072 SemLam ident k -> do

1062 let Tuple level ctx' = nextLevel ctx

1073 let Tuple level ctx' = nextLevel ctx

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

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

1064 SemMkFn pro -> do

1075 SemMkFn pro -> do

1065 let

1076 let

1066 loop ctx' idents = case _ of

1077 loop ctx' idents = case _ of

1067 MkFnNext ident k -> do

1078 MkFnNext ident k -> do

1068 let Tuple lvl ctx'' = nextLevel ctx'

1079 let Tuple lvl ctx'' = nextLevel ctx'

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

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

1070 MkFnApplied body ->

1081 MkFnApplied body ->

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

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

1072 loop ctx [] pro

1083 loop ctx [] pro

@@ -1075,11 +1086,11 @@ quote = go

1075 loop ctx' idents = case _ of

1086 loop ctx' idents = case _ of

1076 MkFnNext ident k -> do

1087 MkFnNext ident k -> do

1077 let Tuple lvl ctx'' = nextLevel ctx'

1088 let Tuple lvl ctx'' = nextLevel ctx'

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

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

1079 MkFnApplied body ->

1090 MkFnApplied body ->

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

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

1081 loop ctx [] pro

1092 loop ctx [] pro

1082− NeutLocal ident level ->

1093+ NeutLocal ident level _ ->

1083 build ctx $ Local ident level

1094 build ctx $ Local ident level

1084 NeutVar qual ->

1095 NeutVar qual ->

1085 build ctx $ Var qual

1096 build ctx $ Var qual

src/PureScript/Backend/Optimizer/Semantics/Foreign.purs+1−1

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

573 )

574 props

575 Just $ NeutLit (LitRecord props')

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

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

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

578 Just $ evalUpdate env r [ update ]

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