blob: 74354641707c77ecb73ff4769aa626ceb9ac4bf9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Simplify where
import Data.Monoid (Sum(..))
import AST
import ASTfunc
import MonMap (MonMap)
import qualified MonMap
simplify :: Expr env t -> Expr env t
simplify e = unSExpr (slr' . sli' . slr' $ toSExpr e)
slr' :: SExpr env t -> SExpr env t
slr' e = slr weakenId e
-- simplify using let-rotate, and work away Unused bindings
slr :: env :> env' -> SExpr env t -> SExpr env' t
slr w (Auto expr) = case expr of
-- unused binding
Let lhs Unused e -> slr (weakenSkip lhs w) e
-- let-rotate
Let lhs (Auto (Let lhs2 rhs2 e2)) e
| Exists lhs' <- rebuildLHS lhs
-> let sh = sinkWithLHS lhs lhs' (weakenWithLHS lhs2)
in slr w (In (Let lhs2 rhs2 (In (Let lhs' e2 (applyShift sh e)))))
-- let-split
Let (L2 l1 l2) (Auto (Pair e1 e2)) e ->
slr w (In (Let l1 e1 (In (Let l2 (applyShift (weakenWithLHS l1) e2) e))))
-- redundant wildcard binding
Let (L0 _) _ e -> slr w e
Const t x -> In (Const t x)
Pair e1 e2 -> In (Pair (slr w e1) (slr w e2))
Nil -> In Nil
Prim op e -> In (Prim op (slr w e))
Var (V t i) -> In (Var (V t (w >:> i)))
Let lhs rhs e
| Exists lhs' <- rebuildLHS lhs
-> In (Let lhs' (slr w rhs) (slr (sinkWithLHS lhs lhs' w) e))
slr _ Unused = error "slr: unused found outside Let RHS"
-- simplify using linear inlining
sli' :: SExpr env t -> SExpr env t
sli' expr =
let (countmp, expr') = count 0 expr
countmp' = ((<= 1) . getSum) <$> countmp
in inline countmp' 0 (Inliner (In . Var)) expr'
count :: Int -> SExpr env t -> (MonMap Int (Sum Int), SExpr env t)
count d (Auto expr) = In <$> case expr of
Const t x -> return (Const t x)
Pair e1 e2 -> Pair <$> count d e1 <*> count d e2
Nil -> return Nil
Prim op e -> Prim op <$> count d e
Var (V t i) -> (MonMap.singleton (d - 1 - idxToInt i) 1, Var (V t i))
Let lhs rhs e -> Let lhs <$> count d rhs <*> count (d + lhsSize lhs) e
count _ Unused = return Unused
lhsSize :: LHS s t env env' -> Int
lhsSize (L0 _) = 0
lhsSize (L1 _) = 0
lhsSize (L2 l1 l2) = lhsSize l1 + lhsSize l2
data Inliner env = Inliner { unInliner :: forall t. V STy env t -> SExpr env t }
inline :: MonMap Int Bool -> Int -> Inliner env -> SExpr env t -> SExpr env t
inline countmp = go
where
go :: Int -> Inliner env -> SExpr env t -> SExpr env t
go d il (Auto expr) = case expr of
Const t x -> In (Const t x)
Pair e1 e2 -> In (Pair (go d il e1) (go d il e2))
Nil -> In Nil
Prim op e -> In (Prim op (go d il e))
Var v -> unInliner il v
Let (L1 t) rhs e
| Just True <- MonMap.lookup d countmp ->
let il' = Inliner
(\case V _ Z -> applyShift weakenSucc rhs
V t' (S i) -> applyShift weakenSucc (unInliner il (V t' i)))
in In (Let (L1 t) Unused (go (d + 1) il' e))
Let lhs rhs e ->
In (Let lhs (go d il rhs)
(go (d + lhsSize lhs) (weakenILwithLHS lhs il) e))
go _ _ Unused = Unused
weakenILwithLHS :: LHS STy t env env' -> Inliner env -> Inliner env'
weakenILwithLHS (L0 _) il = il
weakenILwithLHS (L1 _) il =
Inliner (\case v@(V _ Z) -> In (Var v)
V t (S i) -> applyShift weakenSucc (unInliner il (V t i)))
weakenILwithLHS (L2 l1 l2) il = weakenILwithLHS l2 (weakenILwithLHS l1 il)
data SExpr env t where
Shift :: env :> env' -> PExpr SExpr env t -> SExpr env' t
In :: PExpr SExpr env t -> SExpr env t
Unused :: SExpr env t
toSExpr :: Expr env t -> SExpr env t
toSExpr (Expr e) = In (eInto toSExpr e)
unSExpr :: SExpr env t -> Expr env t
unSExpr (In e) = Expr (eInto unSExpr e)
unSExpr (Shift w e) = Expr (shiftTraverse (eInto unSExpr) w e)
unSExpr Unused = error "unSExpr: unused found"
applyShift :: env :> env' -> SExpr env t -> SExpr env' t
applyShift w (In e) = Shift w e
applyShift w (Shift w' e) = Shift (w >. w') e
applyShift _ Unused = Unused
pattern Auto :: PExpr SExpr env t -> SExpr env t
pattern Auto se <- (matchAuto -> Just se)
{-# COMPLETE Auto, Unused #-}
matchAuto :: SExpr env t -> Maybe (PExpr SExpr env t)
matchAuto (In e) = Just e
matchAuto (Shift w e) = Just (shiftTraverse id w e)
matchAuto Unused = Nothing
shiftTraverse :: (forall env' t'. PExpr SExpr env' t' -> PExpr expr env' t')
-> env :> env1 -> PExpr SExpr env t -> PExpr expr env1 t
shiftTraverse f w e = case e of
Const t x -> Const t x
Pair e1 e2 -> f (Pair (applyShift w e1) (applyShift w e2))
Nil -> Nil
Prim op e1 -> f (Prim op (applyShift w e1))
Var v -> Var (weakenVar w v)
Let lhs rhs e1
| Exists lhs' <- rebuildLHS lhs
-> f (Let lhs' (applyShift w rhs)
(applyShift (sinkWithLHS lhs lhs' w) e1))
|
