Skip to content

Commit 77a24b2

Browse files
AilrunAilrun
committed
Solve exercise 6.4
1 parent d700782 commit 77a24b2

File tree

5 files changed

+482
-0
lines changed

5 files changed

+482
-0
lines changed

‎README.md

+16
Original file line numberDiff line numberDiff line change
@@ -224,6 +224,22 @@ This repository is about an implementation of a simple functional language based
224224
</p>
225225
</details>
226226

227+
### Chapter 6
228+
229+
<details>
230+
<summary>Exercises in Chapter 6</summary>
231+
<p>
232+
233+
| Name | Files |
234+
|--------------|--------------------------------------------------------|
235+
| Exercise 6.1 | /src/Language/Types.hs |
236+
| Exercise 6.2 | /src/Language/Types.hs, /src/Language/PrettyPrinter.hs |
237+
| Exercise 6.3 | /src/Language/LambdaLifting.hs |
238+
| Exercise 6.4 | /src/Language/LambdaLifting.hs |
239+
240+
</p>
241+
</details>
242+
227243
## References
228244

229245
<span id="reference-1">[Simon\[1\]](#text-1): Simon L Peyton Jones, David R Lester. January 1992. _Implementing functional languages: a tutorial_. Prentice Hall</span>

‎package.yaml

+1
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,7 @@ library:
3434
- -D__CLH_EXERCISE_3__=100
3535
- -D__CLH_EXERCISE_4__=100
3636
- -D__CLH_EXERCISE_5__=100
37+
- -D__CLH_EXERCISE_6__=100
3738
## Library fields
3839
#exposed:
3940
#exposed-modules:

‎src/Language/LambdaLifting.hs

+241
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,241 @@
1+
{-# LANGUAGE CPP #-}
2+
module Language.LambdaLifting
3+
( lambdaRun
4+
, lambdaLift
5+
, runS
6+
)
7+
where
8+
9+
import Control.Arrow
10+
import Data.List
11+
import Language.Parser
12+
import Language.PrettyPrinter
13+
import Language.Types
14+
import Util
15+
16+
lambdaRun = putStrLn . runS
17+
18+
lambdaLift :: CoreProgram -> CoreProgram
19+
20+
freeVars :: CoreProgram -> AnnProgram Name (Set Name)
21+
22+
abstract :: AnnProgram Name (Set Name) -> CoreProgram
23+
24+
rename :: CoreProgram -> CoreProgram
25+
26+
collectScs :: CoreProgram -> CoreProgram
27+
28+
lambdaLift = collectScs . rename . abstract . freeVars
29+
30+
runS = prettyPrint . lambdaLift . parse
31+
32+
freeVars program
33+
= [ (name, args, freeVarsE (setFromList args) body)
34+
| (name, args, body) <- program
35+
]
36+
37+
freeVarsE :: Set Name -> CoreExpr -> AnnExpr Name (Set Name)
38+
freeVarsE _ (ENum k) = (setEmpty, ANum k)
39+
freeVarsE lv (EVar v)
40+
| setElementOf v lv = (setSingleton v, AVar v)
41+
| otherwise = (setEmpty, AVar v)
42+
freeVarsE lv (EAp e1 e2)
43+
= (setUnion (freeVarsOf e1') (freeVarsOf e2'), AAp e1' e2')
44+
where
45+
e1' = freeVarsE lv e1
46+
e2' = freeVarsE lv e2
47+
freeVarsE lv (ELam args body)
48+
= (setSubtraction (freeVarsOf body') (setFromList args), ALam args body')
49+
where
50+
body' = freeVarsE newLv body
51+
newLv = setUnion lv (setFromList args)
52+
freeVarsE lv (ELet isRec defns body)
53+
= (setUnion defnsFree bodyFree, ALet isRec defns' body')
54+
where
55+
binders = bindersOf defns
56+
binderSet = setFromList binders
57+
bodyLv = setUnion lv binderSet
58+
rhsLv
59+
| isRec = bodyLv
60+
| otherwise = lv
61+
62+
rhss' = map (freeVarsE rhsLv) (rhssOf defns)
63+
defns' = zip binders rhss'
64+
freeInRhss = setUnionList (map freeVarsOf rhss')
65+
defnsFree
66+
| isRec = setSubtraction freeInRhss binderSet
67+
| otherwise = freeInRhss
68+
body' = freeVarsE bodyLv body
69+
bodyFree = setSubtraction (freeVarsOf body') binderSet
70+
freeVarsE lv (ECase e alts) = freeVarsCase lv e alts
71+
freeVarsE _ (EConstr t a) = (setEmpty, AConstr t a)
72+
73+
freeVarsCase :: Set Name -> CoreExpr -> [CoreAlter] -> AnnExpr Name (Set Name)
74+
#if __CLH_EXERCISE_6__ < 4
75+
freeVarsCase lv e alts = error "freeVarsCase: not yet implemented"
76+
#endif
77+
78+
freeVarsOf :: AnnExpr Name (Set Name) -> Set Name
79+
freeVarsOf (fvs, expr) = fvs
80+
81+
freeVarsOfAlter :: AnnAlter Name (Set Name) -> Set Name
82+
freeVarsOfAlter (tag, args, rhs)
83+
= setSubtraction (freeVarsOf rhs) (setFromList args)
84+
85+
abstract program
86+
= [ (scName, args, abstractE rhs)
87+
| (scName, args, rhs) <- program
88+
]
89+
90+
abstractE :: AnnExpr Name (Set Name) -> CoreExpr
91+
abstractE (_, ANum n) = ENum n
92+
abstractE (_, AVar v) = EVar v
93+
abstractE (_, AAp e1 e2) = EAp (abstractE e1) (abstractE e2)
94+
abstractE (_, ALet isRec defns body)
95+
= ELet isRec (map (second abstractE) defns) (abstractE body)
96+
abstractE (free, ALam args body)
97+
= foldl EAp sc (map EVar fvs)
98+
where
99+
fvs = setToList free
100+
sc = ELet nonRecursive [("sc", scRhs)] (EVar "sc")
101+
scRhs = ELam (fvs ++ args) (abstractE body)
102+
abstractE (_, AConstr t a) = EConstr t a
103+
abstractE (free, ACase e alts) = abstractCase free e alts
104+
105+
abstractCase :: Set Name -> AnnExpr Name (Set Name) -> [AnnAlter Name (Set Name)] -> CoreExpr
106+
#if __CLH_EXERCISE_6__ < 4
107+
abstractCase free e alts = error "abstractCase: not yet implemented"
108+
#endif
109+
110+
rename = snd . mapAccumL renameSc initialNameSupply
111+
where
112+
renameSc ns (scName, args, rhs)
113+
= (ns2, (scName, args', rhs'))
114+
where
115+
(ns1, args', env) = newNames ns args
116+
(ns2, rhs') = renameE env ns1 rhs
117+
118+
newNames :: NameSupply -> [Name] -> (NameSupply, [Name], Assoc Name Name)
119+
newNames ns oldNames
120+
= (ns', newNames, env)
121+
where
122+
(ns', newNames) = getNames ns oldNames
123+
env = zip oldNames newNames
124+
125+
renameE :: Assoc Name Name -> NameSupply -> CoreExpr -> (NameSupply, CoreExpr)
126+
renameE _ ns (ENum n) = (ns, ENum n)
127+
renameE env ns (EVar v) = (ns, EVar (aLookup env v v))
128+
renameE env ns (EAp e1 e2)
129+
= (ns2, EAp e1' e2')
130+
where
131+
(ns1, e1') = renameE env ns e1
132+
(ns2, e2') = renameE env ns1 e2
133+
renameE env ns (ELam args body)
134+
= (ns2, ELam args' body')
135+
where
136+
(ns1, args', env') = newNames ns args
137+
(ns2, body') = renameE (env' ++ env) ns1 body
138+
renameE env ns (ELet isRec defns body)
139+
= (ns3, ELet isRec (zip binders' rhss') body')
140+
where
141+
(ns1, body') = renameE bodyEnv ns body
142+
binders = bindersOf defns
143+
(ns2, binders', env') = newNames ns1 binders
144+
bodyEnv = env' ++ env
145+
(ns3, rhss') = mapAccumL (renameE rhsEnv) ns2 (rhssOf defns)
146+
rhsEnv
147+
| isRec = bodyEnv
148+
| otherwise = env
149+
renameE env ns (EConstr t a) = (ns, EConstr t a)
150+
renameE env ns (ECase e alts) = renameCase env ns e alts
151+
152+
renameCase :: Assoc Name Name -> NameSupply -> CoreExpr -> [CoreAlter] -> (NameSupply, CoreExpr)
153+
#if __CLH_EXERCISE_6__ < 4
154+
renameCase env ns e alts = error "renameCase: not yet implemented"
155+
#endif
156+
157+
collectScs = concatMap collectOneSc
158+
where
159+
collectOneSc (scName, args, rhs)
160+
= (scName, args, rhs') : scs
161+
where
162+
(scs, rhs') = collectScsE rhs
163+
164+
collectScsE :: CoreExpr -> ([CoreScDefn], CoreExpr)
165+
collectScsE (ENum n) = ([], ENum n)
166+
collectScsE (EVar v) = ([], EVar v)
167+
collectScsE (EAp e1 e2) = (scs1 ++ scs2, EAp e1' e2')
168+
where
169+
(scs1, e1') = collectScsE e1
170+
(scs2, e2') = collectScsE e2
171+
collectScsE (ELam args body) = second (ELam args) (collectScsE body)
172+
collectScsE (ELet isRec defns body)
173+
= (rhssScs ++ bodyScs ++ localScs, mkELet isRec nonScs' body')
174+
where
175+
(rhssScs, defns') = mapAccumL collectScsD [] defns
176+
177+
scs' = filter (isELam . snd) defns'
178+
nonScs' = filter (not . isELam . snd) defns'
179+
localScs
180+
= [ (name, args, body)
181+
| (name, ELam args body) <- scs'
182+
]
183+
184+
(bodyScs, body') = collectScsE body
185+
186+
collectScsD scs (name, rhs) = ((scs ++) *** (,) name) (collectScsE rhs)
187+
collectScsE (EConstr t a) = ([], EConstr t a)
188+
collectScsE (ECase e alts)
189+
= (scsE ++ scsAlts, ECase e' alts')
190+
where
191+
(scsE, e') = collectScsE e
192+
(scsAlts, alts') = mapAccumL collectScsAlt [] alts
193+
194+
collectScsAlt scs (tag, args, rhs)
195+
= ((scs ++) *** (,,) tag args) (collectScsE rhs)
196+
197+
isELam :: Expr a -> Bool
198+
isELam (ELam _ _) = True
199+
isELam _ = False
200+
201+
mkELet :: IsRec -> Assoc a (Expr a) -> Expr a -> Expr a
202+
#if __CLH_EXERCISE_6__ < 3
203+
mkELet = ELet
204+
#endif
205+
206+
#if __CLH_EXERCISE_6__ >= 3
207+
mkELet _ [] body = body
208+
mkELet isRec defns body = ELet isRec defns body
209+
210+
#if __CLH_EXERCISE_6__ >= 4
211+
freeVarsCase lv e alts
212+
= (setUnion eFree altsFree, ACase e' alts')
213+
where
214+
e' = freeVarsE lv e
215+
alts' = map freeVarsAlter alts
216+
217+
eFree = freeVarsOf e'
218+
altsFree = setUnionList (map freeVarsOfAlter alts')
219+
220+
freeVarsAlter (tag, args, rhs) = (tag, args, freeVarsE rhsLv rhs)
221+
where
222+
rhsLv = setUnion argSet lv
223+
argSet = setFromList args
224+
225+
abstractCase free e alts = ECase (abstractE e) (map abstractAlter alts)
226+
227+
abstractAlter :: AnnAlter Name (Set Name) -> CoreAlter
228+
abstractAlter (tag, args, rhs) = (tag, args, abstractE rhs)
229+
230+
renameCase env ns e alts = (ns2, ECase e' alts')
231+
where
232+
(ns1, e') = renameE env ns e
233+
(ns2, alts') = mapAccumL (renameAlter env) ns1 alts
234+
235+
renameAlter :: Assoc Name Name -> NameSupply -> CoreAlter -> (NameSupply, CoreAlter)
236+
renameAlter env ns (tag, args, rhs) = (ns2, (tag, args', rhs'))
237+
where
238+
(ns1, args', env') = newNames ns args
239+
(ns2, rhs') = renameE (env' ++ env) ns1 rhs
240+
#endif
241+
#endif

0 commit comments

Comments
 (0)