├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── examples ├── B1-1-UltraBasic1.core ├── B1-1-UltraBasic1.parse ├── B1-1-UltraBasic2.core ├── B1-1-UltraBasic2.parse ├── B1-1-UltraBasic3.core ├── B1-1-UltraBasic3.parse ├── B1-2-Updating1.core ├── B1-2-Updating1.parse ├── B1-3-Interesting1.core ├── B1-3-Interesting1.parse ├── B2-1-LetAndLetrec1.core ├── B2-1-LetAndLetrec1.parse ├── B2-1-LetAndLetrec2.core ├── B2-1-LetAndLetrec2.parse ├── B2-1-LetAndLetrec3.core ├── B2-1-LetAndLetrec3.parse ├── B3-1-NoConditionals1.core ├── B3-1-NoConditionals1.parse ├── B3-1-NoConditionals2.core ├── B3-1-NoConditionals2.parse ├── B3-1-NoConditionals3.core ├── B3-1-NoConditionals3.parse ├── B3-2-WithConditionals1.core ├── B3-2-WithConditionals1.parse ├── B3-2-WithConditionals2.core ├── B3-2-WithConditionals2.parse ├── B3-2-WithConditionals3.core ├── B3-2-WithConditionals3.parse ├── B4-1-DataStructures1.core ├── B4-1-DataStructures1.parse ├── B4-1-DataStructures2.core └── B4-1-DataStructures2.parse ├── exercises ├── exercise1-01.xls ├── exercise1-04.xls ├── exercise1-22.md ├── exercise2-01.md ├── exercise2-02.md ├── exercise2-08.md ├── exercise2-09.md ├── exercise2-12.md ├── exercise2-13.md ├── exercise2-15.md ├── exercise2-18.md ├── exercise2-19.md ├── exercise2-20.core ├── exercise2-22.md ├── exercise2-23.core ├── exercise2-24.md ├── exercise2-25.md ├── exercise2-29.md ├── exercise2-34.md ├── exercise3-01.v ├── exercise3-02.v ├── exercise3-03.md ├── exercise3-04.md ├── exercise3-11.md ├── exercise3-17.core ├── exercise3-19.compiled ├── exercise3-20.md ├── exercise3-24.md ├── exercise3-26.md ├── exercise3-29.core ├── exercise3-45.md ├── exercise3-47.md ├── exercise4-09.md ├── exercise4-10.md ├── exercise4-12.md ├── exercise5-04.md ├── exercise5-06.md ├── exercise5-07.md ├── exercise5-10.md ├── exercise5-11.md ├── exercise5-12.md └── exercise6-13.v ├── package.yaml ├── src ├── Data │ ├── ISeq.hs │ └── StatHeap.hs ├── Language │ ├── GMachine.hs │ ├── LambdaLifting.hs │ ├── ParGMachine.hs │ ├── Parser.hs │ ├── Prelude.hs │ ├── PrettyPrinter.hs │ ├── TIM.hs │ ├── TiMachine.hs │ ├── TiMachineAlter.hs │ ├── TiMachineGC.hs │ └── Types.hs └── Util.hs ├── stack.yaml └── test ├── Fixtures └── Examples.hs ├── Language └── ParserSpec.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | # Haskell 2 | *.hi 3 | *.o 4 | 5 | # Cabal 6 | *.cabal 7 | 8 | # Haskell Tool Stack 9 | .stack-work/ 10 | dist/ 11 | 12 | # Emacs 13 | .dir-locals.el 14 | *~ 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Junyoung Clare Jang (c) 2019 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Junyoung Clare Jang nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # core-lang-haskell 2 | 3 | This repository is about an implementation of a simple functional language based on [Simon\[1\]](#reference-1). 4 | 5 | ## Exercises 6 | 7 | ### Chapter 1 8 | 9 |
10 | Exercises in Chapter 1 11 |

12 | 13 | | Name | Files | 14 | |---------------|-------------------------------------------------------------| 15 | | Exercise 1.1 | /exercises/exercise1-01.xls, /src/Language/PrettyPrinter.hs | 16 | | Exercise 1.2 | /src/Data/ISeq.hs | 17 | | Exercise 1.3 | /src/Language/PrettyPrinter.hs | 18 | | Exercise 1.4 | /exercises/exercise1-04.xls, /src/Language/PrettyPrinter.hs | 19 | | Exercise 1.5 | /src/Data/ISeq.hs | 20 | | Exercise 1.6 | /src/Data/ISeq.hs | 21 | | Exercise 1.7 | /src/Data/ISeq.hs | 22 | | Exercise 1.8 | /src/Language/PrettyPrinter.hs | 23 | | Exercise 1.9 | /src/Language/Parser.hs | 24 | | Exercise 1.10 | /src/Language/Parser.hs | 25 | | Exercise 1.11 | /src/Lanugage/Parser.hs | 26 | | Exercise 1.12 | /src/Lanugage/Parser.hs | 27 | | Exercise 1.13 | /src/Lanugage/Parser.hs | 28 | | Exercise 1.14 | /src/Lanugage/Parser.hs | 29 | | Exercise 1.15 | /src/Lanugage/Parser.hs | 30 | | Exercise 1.16 | /src/Lanugage/Parser.hs | 31 | | Exercise 1.17 | /src/Lanugage/Parser.hs | 32 | | Exercise 1.18 | /src/Lanugage/Parser.hs | 33 | | Exercise 1.19 | /src/Lanugage/Parser.hs | 34 | | Exercise 1.20 | /src/Lanugage/Parser.hs | 35 | | Exercise 1.21 | /src/Lanugage/Parser.hs | 36 | | Exercise 1.22 | /exercises/exercise1-22.md | 37 | | Exercise 1.23 | /src/Lanugage/Parser.hs | 38 | | Exercise 1.24 | /src/Lanugage/Parser.hs | 39 | 40 |

41 |
42 | 43 | ### Chapter 2 44 | 45 |
46 | Exercises in Chapter 2 47 |

48 | 49 | | Name | Files | 50 | |---------------|-------------------------------------------------------------| 51 | | Exercise 2.1 | /exercises/exercise2-01.md | 52 | | Exercise 2.2 | /exercises/exercise2-02.md | 53 | | Exercise 2.3 | _skipped_ | 54 | | Exercise 2.4 | /src/Language/TiMachine.hs | 55 | | Exercise 2.5 | /src/Language/TiMachine.hs | 56 | | Exercise 2.6 | /src/Language/TiMachine.hs | 57 | | Exercise 2.7 | /src/Language/TiMachine.hs | 58 | | Exercise 2.8 | /exercises/exercise2-08.md | 59 | | Exercise 2.9 | /exercises/exercise2-09.md | 60 | | Exercise 2.10 | /src/Language/TiMachine.hs | 61 | | Exercise 2.11 | /src/Language/TiMachine.hs | 62 | | Exercise 2.12 | /exercises/exercise2-12.md | 63 | | Exercise 2.13 | /src/Language/TiMachine.hs, /exercises/exercise2-13.md | 64 | | Exercise 2.14 | /src/Language/TiMachine.hs | 65 | | Exercise 2.15 | /exercises/exercise2-15.md | 66 | | Exercise 2.16 | /src/Language/TiMachine.hs | 67 | | Exercise 2.17 | /src/Language/TiMachine.hs | 68 | | Exercise 2.18 | /src/Language/TiMachine.hs, /exercises/exercise2-18.md | 69 | | Exercise 2.19 | /exercises/exercise2-19.md | 70 | | Exercise 2.20 | /src/Language/TiMachine.hs, /exercises/exercise2-20.core | 71 | | Exercise 2.21 | /src/Language/TiMachine.hs | 72 | | Exercise 2.22 | /src/Language/TiMachine.hs, /exercises/exercise2-22.md | 73 | | Exercise 2.23 | /exercises/exercise2-23.core | 74 | | Exercise 2.24 | /src/Language/TiMachine.hs, /exercises/exercise2-24.md | 75 | | Exercise 2.25 | /exercises/exercise2-25.md | 76 | | Exercise 2.26 | /src/Language/TiMachine.hs | 77 | | Exercise 2.27 | /src/Language/TiMachineAlter.hs | 78 | | Exercise 2.28 | /src/Language/TiMachineAlter.hs | 79 | | Exercise 2.29 | /src/Language/TiMachineAlter.hs, /exercises/exercise2-29.md | 80 | | Exercise 2.30 | /src/Language/TiMachineGC.hs | 81 | | Exercise 2.31 | /src/Language/TiMachineGC.hs | 82 | | Exercise 2.32 | /src/Language/TiMachineGC.hs | 83 | | Exercise 2.33 | /src/Language/TiMachineGC.hs | 84 | | Exercise 2.34 | /exercises/exercise2-34.md | 85 | | Exercise 2.35 | /src/Language/TiMachineGC.hs | 86 | | Exercise 2.36 | /src/Language/TiMachineGC.hs | 87 | 88 |

89 |
90 | 91 | ### Chapter 3 92 | 93 |
94 | Exercises in Chapter 3 95 |

96 | 97 | | Name | Files | 98 | |---------------|-------------------------------------------------------| 99 | | Exercise 3.1 | /exercises/exercise3-01.v | 100 | | Exercise 3.2 | ~/exercises/exercise3-02.v~ | 101 | | Exercise 3.3 | /exercises/exercise3-03.md | 102 | | Exercise 3.4 | /exercises/exercise3-04.md | 103 | | Exercise 3.5 | _skipped_ | 104 | | Exercise 3.6 | /src/Language/GMachine.hs | 105 | | Exercise 3.7 | /src/Language/GMachine.hs | 106 | | Exercise 3.8 | /src/Language/GMachine.hs | 107 | | Exercise 3.9 | /src/Language/GMachine.hs | 108 | | Exercise 3.10 | /src/Language/GMachine.hs | 109 | | Exercise 3.11 | /exercises/exercise3-11.md | 110 | | Exercise 3.12 | /src/Language/GMachine.hs | 111 | | Exercise 3.13 | _skipped_ | 112 | | Exercise 3.14 | /src/Language/GMachine.hs | 113 | | Exercise 3.15 | /src/Language/GMachine.hs | 114 | | Exercise 3.16 | /src/Language/GMachine.hs | 115 | | Exercise 3.17 | /exercises/exercise3-17.core | 116 | | Exercise 3.18 | _skipped_ | 117 | | Exercise 3.19 | /exercises/exercise3-19.compiled | 118 | | Exercise 3.20 | /exercises/exercise3-20.md | 119 | | Exercise 3.21 | /src/Language/GMachine.hs | 120 | | Exercise 3.22 | /src/Language/GMachine.hs | 121 | | Exercise 3.23 | /src/Language/GMachine.hs | 122 | | Exercise 3.24 | /exercises/exercise3-24.md | 123 | | Exercise 3.25 | /src/Language/GMachine.hs | 124 | | Exercise 3.26 | /exercises/exercise3-26.md | 125 | | Exercise 3.27 | /src/Language/GMachine.hs | 126 | | Exercise 3.28 | /src/Language/GMachine.hs | 127 | | Exercise 3.29 | /src/Language/GMachine.hs, /exercises/exercise3-29.md | 128 | | Exercise 3.30 | _skipped_ | 129 | | Exercise 3.31 | /src/Language/GMachine.hs | 130 | | Exercise 3.32 | /src/Language/GMachine.hs | 131 | | Exercise 3.33 | /src/Language/GMachine.hs | 132 | | Exercise 3.34 | /src/Language/GMachine.hs | 133 | | Exercise 3.35 | /src/Language/GMachine.hs | 134 | | Exercise 3.36 | _skipped_ | 135 | | Exercise 3.37 | /src/Language/GMachine.hs | 136 | | Exercise 3.38 | /src/Language/GMachine.hs | 137 | | Exercise 3.39 | /src/Language/GMachine.hs | 138 | | Exercise 3.40 | /src/Language/GMachine.hs | 139 | | Exercise 3.41 | /src/Language/GMachine.hs | 140 | | Exercise 3.42 | /src/Language/GMachine.hs | 141 | | Exercise 3.43 | /src/Language/GMachine.hs | 142 | | Exercise 3.44 | /src/Language/GMachine.hs | 143 | | Exercise 3.45 | /exercises/exercise3-45.md | 144 | | Exercise 3.46 | /src/Language/GMachine.hs | 145 | | Exercise 3.47 | /src/Language/GMachine.hs, /exercises/exercise3-47.md | 146 | 147 |

148 |
149 | 150 | ### Chapter 4 151 | 152 |
153 | Exercises in Chapter 4 154 |

155 | 156 | | Name | Files | 157 | |---------------|----------------------------| 158 | | Exercise 4.1 | /src/Language/TIM.hs | 159 | | Exercise 4.2 | /src/Language/TIM.hs | 160 | | Exercise 4.3 | /src/Language/TIM.hs | 161 | | Exercise 4.4 | /src/Language/TIM.hs | 162 | | Exercise 4.5 | /src/Language/TIM.hs | 163 | | Exercise 4.6 | /src/Language/TIM.hs | 164 | | Exercise 4.7 | /src/Language/TIM.hs | 165 | | Exercise 4.8 | /src/Language/TIM.hs | 166 | | Exercise 4.9 | /exercises/exercise4-09.md | 167 | | Exercise 4.10 | /exercises/exercise4-10.md | 168 | | Exercise 4.11 | /src/Language/TIM.hs | 169 | | Exercise 4.12 | /exercises/exercise4-12.md | 170 | | Exercise 4.13 | /src/Language/TIM.hs | 171 | | Exercise 4.14 | /src/Language/TIM.hs | 172 | | Exercise 4.15 | /src/Language/TIM.hs | 173 | | Exercise 4.16 | /src/Language/TIM.hs | 174 | | Exercise 4.17 | /src/Language/TIM.hs | 175 | | Exercise 4.18 | /src/Language/TIM.hs | 176 | | Exercise 4.19 | /src/Language/TIM.hs | 177 | | Exercise 4.20 | /src/Language/TIM.hs | 178 | | Exercise 4.21 | /src/Language/TIM.hs | 179 | | Exercise 4.22 | /src/Language/TIM.hs | 180 | | Exercise 4.23 | /src/Language/TIM.hs | 181 | | Exercise 4.24 | /src/Language/TIM.hs | 182 | | Exercise 4.25 | /src/Language/TIM.hs | 183 | | Exercise 4.26 | /src/Language/TIM.hs | 184 | | Exercise 4.27 | /src/Language/TIM.hs | 185 | | Exercise 4.28 | /src/Language/TIM.hs | 186 | | Exercise 4.29 | /src/Language/TIM.hs | 187 | | Exercise 4.30 | /src/Language/TIM.hs | 188 | 189 |

190 |
191 | 192 | ### Chapter 5 193 | 194 |
195 | Exercises in Chapter 5 196 |

197 | 198 | | Name | Files | 199 | |---------------|------------------------------| 200 | | Exercise 5.1 | /src/Language/ParGMachine.hs | 201 | | Exercise 5.2 | /src/Language/ParGMachine.hs | 202 | | Exercise 5.3 | /src/Language/ParGMachine.hs | 203 | | Exercise 5.4 | /exercises/exercise5-04.md | 204 | | Exercise 5.5 | /src/Language/ParGMachine.hs | 205 | | Exercise 5.6 | /exercises/exercise5-06.md | 206 | | Exercise 5.7 | /exercises/exercise5-07.md | 207 | | Exercise 5.8 | /src/Language/ParGMachine.hs | 208 | | Exercise 5.9 | /src/Language/ParGMachine.hs | 209 | | Exercise 5.10 | /exercises/exercise5-10.md | 210 | | Exercise 5.11 | /exercises/exercise5-11.md | 211 | | Exercise 5.12 | /exercises/exercise5-12.md | 212 | | Exercise 5.13 | /src/Language/ParGMachine.hs | 213 | | Exercise 5.14 | /src/Language/ParGMachine.hs | 214 | | Exercise 5.15 | /src/Language/ParGMachine.hs | 215 | | Exercise 5.16 | _skipped_ | 216 | | Exercise 5.17 | /src/Language/ParGMachine.hs | 217 | | Exercise 5.18 | /src/Language/ParGMachine.hs | 218 | | Exercise 5.19 | /src/Language/ParGMachine.hs | 219 | | Exercise 5.20 | /src/Language/ParGMachine.hs | 220 | | Exercise 5.21 | /src/Language/ParGMachine.hs | 221 | | Exercise 5.22 | /src/Language/ParGMachine.hs | 222 | | Exercise 5.23 | /src/Language/ParGMachine.hs | 223 | 224 |

225 |
226 | 227 | ### Chapter 6 228 | 229 |
230 | Exercises in Chapter 6 231 |

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 | | Exercise 6.5 | /src/Language/LambdaLifting.hs | 240 | | Exercise 6.6 | /src/Language/LambdaLifting.hs | 241 | | Exercise 6.7 | /src/Language/LambdaLifting.hs | 242 | | Exercise 6.8 | /src/Language/LambdaLifting.hs | 243 | | Exercise 6.9 | /src/Language/LambdaLifting.hs | 244 | | Exercise 6.10 | /src/Language/LambdaLifting.hs | 245 | | Exercise 6.11 | /src/Language/LambdaLifting.hs | 246 | | Exercise 6.12 | /src/Language/LambdaLifting.hs | 247 | | Exercise 6.13 | /exercises/exercise6-13.v | 248 | | Exercise 6.14 | /src/Language/LambdaLifting.hs, _The proof is skipped_ | 249 | | Exercise 6.15 | /src/Language/LambdaLifting.hs, _The proof is skipped_ | 250 | | Exercise 6.16 | /src/Language/LambdaLifting.hs | 251 | 252 |

253 |
254 | 255 | ## References 256 | 257 | [Simon\[1\]](#text-1): Simon L Peyton Jones, David R Lester. January 1992. _Implementing functional languages: a tutorial_. Prentice Hall 258 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn "Do nothing" 5 | -------------------------------------------------------------------------------- /examples/B1-1-UltraBasic1.core: -------------------------------------------------------------------------------- 1 | main = I 3 2 | -------------------------------------------------------------------------------- /examples/B1-1-UltraBasic1.parse: -------------------------------------------------------------------------------- 1 | [("main",[],EAp (EVar "I") (ENum 3))] 2 | -------------------------------------------------------------------------------- /examples/B1-1-UltraBasic2.core: -------------------------------------------------------------------------------- 1 | id = S K K ; 2 | main = id 3 3 | -------------------------------------------------------------------------------- /examples/B1-1-UltraBasic2.parse: -------------------------------------------------------------------------------- 1 | [("id",[],EAp (EAp (EVar "S") (EVar "K")) (EVar "K")),("main",[],EAp (EVar "id") (ENum 3))] 2 | -------------------------------------------------------------------------------- /examples/B1-1-UltraBasic3.core: -------------------------------------------------------------------------------- 1 | id = S K K ; 2 | main = twice twice twice id 3 3 | -------------------------------------------------------------------------------- /examples/B1-1-UltraBasic3.parse: -------------------------------------------------------------------------------- 1 | [("id",[],EAp (EAp (EVar "S") (EVar "K")) (EVar "K")),("main",[],EAp (EAp (EAp (EAp (EVar "twice") (EVar "twice")) (EVar "twice")) (EVar "id")) (ENum 3))] 2 | -------------------------------------------------------------------------------- /examples/B1-2-Updating1.core: -------------------------------------------------------------------------------- 1 | main = twice (I I I) 3 2 | -------------------------------------------------------------------------------- /examples/B1-2-Updating1.parse: -------------------------------------------------------------------------------- 1 | [("main",[],EAp (EAp (EVar "twice") (EAp (EAp (EVar "I") (EVar "I")) (EVar "I"))) (ENum 3))] 2 | -------------------------------------------------------------------------------- /examples/B1-3-Interesting1.core: -------------------------------------------------------------------------------- 1 | cons a b cc cn = cc a b ; 2 | nil cc cn = cn ; 3 | hd list = list K abort ; 4 | tl list = list K1 abort ; 5 | abort = abort ; 6 | 7 | infinite x = cons x (infinite x) ; 8 | 9 | main = hd (tl (infinite 4)) 10 | -------------------------------------------------------------------------------- /examples/B1-3-Interesting1.parse: -------------------------------------------------------------------------------- 1 | [("cons",["a","b","cc","cn"],EAp (EAp (EVar "cc") (EVar "a")) (EVar "b")),("nil",["cc","cn"],EVar "cn"),("hd",["list"],EAp (EAp (EVar "list") (EVar "K")) (EVar "abort")),("tl",["list"],EAp (EAp (EVar "list") (EVar "K1")) (EVar "abort")),("abort",[],EVar "abort"),("infinite",["x"],EAp (EAp (EVar "cons") (EVar "x")) (EAp (EVar "infinite") (EVar "x"))),("main",[],EAp (EVar "hd") (EAp (EVar "tl") (EAp (EVar "infinite") (ENum 4))))] 2 | -------------------------------------------------------------------------------- /examples/B2-1-LetAndLetrec1.core: -------------------------------------------------------------------------------- 1 | main = let id1 = I I I 2 | in id1 id1 3 3 | -------------------------------------------------------------------------------- /examples/B2-1-LetAndLetrec1.parse: -------------------------------------------------------------------------------- 1 | [("main",[],ELet False [("id1",EAp (EAp (EVar "I") (EVar "I")) (EVar "I"))] (EAp (EAp (EVar "id1") (EVar "id1")) (ENum 3)))] 2 | -------------------------------------------------------------------------------- /examples/B2-1-LetAndLetrec2.core: -------------------------------------------------------------------------------- 1 | oct g x = let h = twice g 2 | in let k = twice h 3 | in k (k x) ; 4 | main = oct I 4 5 | -------------------------------------------------------------------------------- /examples/B2-1-LetAndLetrec2.parse: -------------------------------------------------------------------------------- 1 | [("oct",["g","x"],ELet False [("h",EAp (EVar "twice") (EVar "g"))] (ELet False [("k",EAp (EVar "twice") (EVar "h"))] (EAp (EVar "k") (EAp (EVar "k") (EVar "x"))))),("main",[],EAp (EAp (EVar "oct") (EVar "I")) (ENum 4))] 2 | -------------------------------------------------------------------------------- /examples/B2-1-LetAndLetrec3.core: -------------------------------------------------------------------------------- 1 | infinite x = letrec xs = cons x xs 2 | in xs ; 3 | main = hd (tl (tl (infinite 4))) 4 | -------------------------------------------------------------------------------- /examples/B2-1-LetAndLetrec3.parse: -------------------------------------------------------------------------------- 1 | [("infinite",["x"],ELet True [("xs",EAp (EAp (EVar "cons") (EVar "x")) (EVar "xs"))] (EVar "xs")),("main",[],EAp (EVar "hd") (EAp (EVar "tl") (EAp (EVar "tl") (EAp (EVar "infinite") (ENum 4)))))] 2 | -------------------------------------------------------------------------------- /examples/B3-1-NoConditionals1.core: -------------------------------------------------------------------------------- 1 | main = 4*5+(2-5) 2 | -------------------------------------------------------------------------------- /examples/B3-1-NoConditionals1.parse: -------------------------------------------------------------------------------- 1 | [("main",[],EAp (EAp (EVar "+") (EAp (EAp (EVar "*") (ENum 4)) (ENum 5))) (EAp (EAp (EVar "-") (ENum 2)) (ENum 5)))] 2 | -------------------------------------------------------------------------------- /examples/B3-1-NoConditionals2.core: -------------------------------------------------------------------------------- 1 | inc x = x+1; 2 | main = twice twice inc 4 3 | -------------------------------------------------------------------------------- /examples/B3-1-NoConditionals2.parse: -------------------------------------------------------------------------------- 1 | [("inc",["x"],EAp (EAp (EVar "+") (EVar "x")) (ENum 1)),("main",[],EAp (EAp (EAp (EVar "twice") (EVar "twice")) (EVar "inc")) (ENum 4))] 2 | -------------------------------------------------------------------------------- /examples/B3-1-NoConditionals3.core: -------------------------------------------------------------------------------- 1 | length xs = xs length1 0 ; 2 | length1 x xs = 1 + (length xs) ; 3 | 4 | main = length (cons 3 (cons 3 (cons 3 nil))) 5 | -------------------------------------------------------------------------------- /examples/B3-1-NoConditionals3.parse: -------------------------------------------------------------------------------- 1 | [("length",["xs"],EAp (EAp (EVar "xs") (EVar "length1")) (ENum 0)),("length1",["x","xs"],EAp (EAp (EVar "+") (ENum 1)) (EAp (EVar "length") (EVar "xs"))),("main",[],EAp (EVar "length") (EAp (EAp (EVar "cons") (ENum 3)) (EAp (EAp (EVar "cons") (ENum 3)) (EAp (EAp (EVar "cons") (ENum 3)) (EVar "nil")))))] 2 | -------------------------------------------------------------------------------- /examples/B3-2-WithConditionals1.core: -------------------------------------------------------------------------------- 1 | fac n = if (n==0) 1 (n * fac (n-1)) ; 2 | main = fac 5 3 | -------------------------------------------------------------------------------- /examples/B3-2-WithConditionals1.parse: -------------------------------------------------------------------------------- 1 | [("fac",["n"],EAp (EAp (EAp (EVar "if") (EAp (EAp (EVar "==") (EVar "n")) (ENum 0))) (ENum 1)) (EAp (EAp (EVar "*") (EVar "n")) (EAp (EVar "fac") (EAp (EAp (EVar "-") (EVar "n")) (ENum 1))))),("main",[],EAp (EVar "fac") (ENum 5))] 2 | -------------------------------------------------------------------------------- /examples/B3-2-WithConditionals2.core: -------------------------------------------------------------------------------- 1 | gcd a b = if (a==b) 2 | a 3 | (if (a -> Nil ; 7 | <2> p ps -> Cons p (sieve (filter (nonMultiple p) ps)) ; 8 | 9 | filter predicate xs 10 | = case xs of 11 | <1> -> Nil ; 12 | <2> p ps -> let rest = filter predicate ps 13 | in 14 | if (predicate p) (Cons p rest) rest ; 15 | 16 | nonMultiple p n = ((n/p)*p) ~= n ; 17 | 18 | take n xs = if (n==0) 19 | Nil 20 | (case xs of 21 | <1> -> Nil ; 22 | <2> p ps -> Cons p (take (n-1) ps)) 23 | -------------------------------------------------------------------------------- /examples/B4-1-DataStructures2.parse: -------------------------------------------------------------------------------- 1 | [("main",[],EAp (EAp (EVar "take") (ENum 3)) (EAp (EVar "sieve") (EAp (EVar "from") (ENum 2)))),("from",["n"],EAp (EAp (EVar "Cons") (EVar "n")) (EAp (EVar "from") (EAp (EAp (EVar "+") (EVar "n")) (ENum 1)))),("sieve",["xs"],ECase (EVar "xs") [(1,[],EVar "Nil"),(2,["p","ps"],EAp (EAp (EVar "Cons") (EVar "p")) (EAp (EVar "sieve") (EAp (EAp (EVar "filter") (EAp (EVar "nonMultiple") (EVar "p"))) (EVar "ps"))))]),("filter",["predicate","xs"],ECase (EVar "xs") [(1,[],EVar "Nil"),(2,["p","ps"],ELet False [("rest",EAp (EAp (EVar "filter") (EVar "predicate")) (EVar "ps"))] (EAp (EAp (EAp (EVar "if") (EAp (EVar "predicate") (EVar "p"))) (EAp (EAp (EVar "Cons") (EVar "p")) (EVar "rest"))) (EVar "rest")))]),("nonMultiple",["p","n"],EAp (EAp (EVar "~=") (EAp (EAp (EVar "*") (EAp (EAp (EVar "/") (EVar "n")) (EVar "p"))) (EVar "p"))) (EVar "n")),("take",["n","xs"],EAp (EAp (EAp (EVar "if") (EAp (EAp (EVar "==") (EVar "n")) (ENum 0))) (EVar "Nil")) (ECase (EVar "xs") [(1,[],EVar "Nil"),(2,["p","ps"],EAp (EAp (EVar "Cons") (EVar "p")) (EAp (EAp (EVar "take") (EAp (EAp (EVar "-") (EVar "n")) (ENum 1))) (EVar "ps")))]))] 2 | -------------------------------------------------------------------------------- /exercises/exercise1-01.xls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Ailrun/core-lang-haskell/f6f700ad08fe31bd765381b7e18b747ff2f07c44/exercises/exercise1-01.xls -------------------------------------------------------------------------------- /exercises/exercise1-04.xls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Ailrun/core-lang-haskell/f6f700ad08fe31bd765381b7e18b747ff2f07c44/exercises/exercise1-04.xls -------------------------------------------------------------------------------- /exercises/exercise1-22.md: -------------------------------------------------------------------------------- 1 | In following example, 2 | 3 | ``` 4 | f x y = case x of 5 | <1> -> case y of 6 | <1> -> 1; 7 | <2> -> 2 8 | ``` 9 | 10 | `<2>` will be a part of `case y of ...` with the current parser. 11 | -------------------------------------------------------------------------------- /exercises/exercise2-01.md: -------------------------------------------------------------------------------- 1 | | n | m | d | t | _remarks_ | 2 | |---|---|---|---|-----------| 3 | | 2 | 3 | 0 | 0 | initial | 4 | | 2 | 2 | 2 | 0 | | 5 | | 2 | 2 | 1 | 1 | | 6 | | 2 | 2 | 0 | 2 | | 7 | | 2 | 1 | 2 | 2 | | 8 | | 2 | 1 | 1 | 3 | | 9 | | 2 | 1 | 0 | 4 | | 10 | | 2 | 0 | 2 | 4 | | 11 | | 2 | 0 | 1 | 5 | | 12 | | 2 | 0 | 0 | 6 | final | 13 | -------------------------------------------------------------------------------- /exercises/exercise2-02.md: -------------------------------------------------------------------------------- 1 | Invariant of the machine is 2 | 3 | > `N * M = N * m + d + t` 4 | 5 | 1. This invariant is true for initial state because 6 | > `N * M = N * M + 0 + 0` 7 | 1. If this invariant is true for a specific state, then it is also true for its successor state, because 8 | > `N * M = N * m + d + t = N * m + (d - 1) + (t + 1)` 9 | is true for the first rule and 10 | > `N * M = N * m + 0 + t = N * (m - 1) + N + t` 11 | is true for the second rule. 12 | 1. If this invariant is true, then in a final state, `t = N * M` is true, because 13 | > `N * M = N * m + d + t = N * 0 + 0 + t = t` 14 | -------------------------------------------------------------------------------- /exercises/exercise2-08.md: -------------------------------------------------------------------------------- 1 | If the order is reversed, the `globals` will shadow arguments if one of arguments use a identifier that already exists in the `globals`, which is usually not desired. 2 | -------------------------------------------------------------------------------- /exercises/exercise2-09.md: -------------------------------------------------------------------------------- 1 | If we change the definition, an errorsome `state` will not be printed since `eval state` for the errorsome `state` will not return anything. 2 | 3 | With current implementation, `eval state` always return `state:someChunk` and `someChunk` will be evaluated later when needed. 4 | -------------------------------------------------------------------------------- /exercises/exercise2-12.md: -------------------------------------------------------------------------------- 1 | The program will not terminate until a memory problem occurs. The problem cannot arise in strongly typed languages, since `x` is not defined and compilers emit error about it. 2 | -------------------------------------------------------------------------------- /exercises/exercise2-13.md: -------------------------------------------------------------------------------- 1 | The machine with updates gives much less numbers of steps. 2 | -------------------------------------------------------------------------------- /exercises/exercise2-15.md: -------------------------------------------------------------------------------- 1 | ## Rule 1 - Evaluation Rule 2 | | stack | dump | heap | globals | 3 | |------------------|------|---------------------------------------------------------------------------------------------------------------------------------------------------------------|---------| 4 | | a : a1 : a2 : [] | d | h[
  a : NPrim Add
  a1 : NAp a b1
  a2 : NAp a1 b2
  b1 : NNum n1
  b2 : NNum n2
] | f | 5 | | a2 : [] | d | h[a2 : NNum (n1 + n2)] | f | 6 | 7 | ## Rule 2 - If Rule 1 Is Not Applicable 8 | | stack | dump | heap | globals | 9 | |------------------|--------------------|----------------------------------------------------------------------------------------------------------------------------------|---------| 10 | | a : a1 : a2 : [] | d | h[
  a : NPrim Add
  a1 : NAp a b1
  a2 : NAp a1 b2
  b2 : NNum n2
] | f | 11 | | b1 : [] | (a1 : a2 : []) : d | h | f | 12 | 13 | ## Rule 3 - If Rule 1 & Rule 2 Are Not Applicable 14 | | stack | dump | heap | globals | 15 | |------------------|---------------|-----------------------------------------------------------------------------------------------------|---------| 16 | | a : a1 : a2 : [] | d | h[
  a : NPrim Add
  a1 : NAp a b1
  a2 : NAp a1 b2
] | f | 17 | | b2 : [] | (a2 : []) : d | h | f | 18 | -------------------------------------------------------------------------------- /exercises/exercise2-18.md: -------------------------------------------------------------------------------- 1 | I don't know why. I implemented one in `TiMachine.hs` and it works well... 2 | Is my implementation too complex? 3 | 4 | One can try it with `-D__CLH_EXERCISE_2__=18` Option. 5 | -------------------------------------------------------------------------------- /exercises/exercise2-19.md: -------------------------------------------------------------------------------- 1 | ## Rule 1 - Evaluation Rule For False 2 | | stack | dump | heap | globals | 3 | |-----------------------|------|--------------------------------------------------------------------------------------------------------------------------------------------------------------------|---------| 4 | | a : a1 : a2 : a3 : [] | d | h[
  a : NPrim NIf
  a1 : NAp a b1
  a2 : NAp a1 b2
  a3 : NAp a2 b3
  b1 : NData 1 []
] | f | 5 | | a3 : [] | d | h[a3 : NInd b3] | f | 6 | 7 | ## Rule 2 - Evaluation Rule For True 8 | | stack | dump | heap | globals | 9 | |-----------------------|------|--------------------------------------------------------------------------------------------------------------------------------------------------------------------|---------| 10 | | a : a1 : a2 : a3 : [] | d | h[
  a : NPrim NIf
  a1 : NAp a b1
  a2 : NAp a1 b2
  a3 : NAp a2 b3
  b1 : NData 2 []
] | f | 11 | | a3 : [] | d | h[a3 : NInd b2] | f | 12 | 13 | ## Rule 3 - If Rule 1 & Rule 2 Are Not Applicable 14 | | stack | dump | heap | globals | 15 | |-----------------------|-------------------------|------------------------------------------------------------------------------------------------------------------------------------|---------| 16 | | a : a1 : a2 : a3 : [] | d | h[
  a : NPrim NIf
  a1 : NAp a b1
  a2 : NAp a1 b2
  a3 : NAp a2 b3
] | f | 17 | | b1 : [] | (a1 : a2 : a3 : []) : d | h | f | 18 | -------------------------------------------------------------------------------- /exercises/exercise2-20.core: -------------------------------------------------------------------------------- 1 | or x y = if x True y; 2 | xor x y = if x (not y) y; 3 | not y = if y False True 4 | -------------------------------------------------------------------------------- /exercises/exercise2-22.md: -------------------------------------------------------------------------------- 1 | ## Rule 1 - Evaluation Rule 2 | | stack | dump | heap | globals | 3 | |------------------|------|-------------------------------------------------------------------------------------------------------------------------------------------------|---------| 4 | | a : a1 : a2 : [] | d | h[
  a : NPrim NCasePair
  a1 : NAp a b1
  a2 : NAp a1 b2
  b1 : NData 1 [c1, c2]
] | f | 5 | | a2 : [] | d | h[
  a2 : NAp a3 c2
  a3 : NAp b2 c1
] | f | 6 | 7 | ## Rule 2 - If Rule 1 Is Not Applicable 8 | | stack | dump | heap | globals | 9 | |------------------|--------------------|-----------------------------------------------------------------------------------------------------------|---------| 10 | | a : a1 : a2 : [] | d | h[
  a : NPrim NCasePair
  a1 : NAp a b1
  a2 : NAp a1 b2
] | f | 11 | | b1 : [] | (a1 : a2 : []) : d | h | f | 12 | -------------------------------------------------------------------------------- /exercises/exercise2-23.core: -------------------------------------------------------------------------------- 1 | Nil = Pack{1,0} 2 | Cons = Pack{2,2} 3 | 4 | head l = caseList l abort K 5 | tail l = caseList l abort K1 6 | -------------------------------------------------------------------------------- /exercises/exercise2-24.md: -------------------------------------------------------------------------------- 1 | ## Rule 1 - Evaluation Rule For Nil 2 | | stack | dump | heap | globals | 3 | |-----------------------|------|--------------------------------------------------------------------------------------------------------------------------------------------------------------------------|---------| 4 | | a : a1 : a2 : a3 : [] | d | h[
  a : NPrim NCaseList
  a1 : NAp a b1
  a2 : NAp a1 b2
  a3 : NAp a2 b3
  b1 : NData 1 []
] | f | 5 | | a3 : [] | d | h[
  a3 : NInd b2
] | f | 6 | 7 | ## Rule 2 - Evaluation Rule For Cons 8 | | stack | dump | heap | globals | 9 | |-----------------------|------|--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------|---------| 10 | | a : a1 : a2 : a3 : [] | d | h[
  a : NPrim NCaseList
  a1 : NAp a b1
  a2 : NAp a1 b2
  a3 : NAp a2 b3
  b1 : NData 2 [c1, c2]
] | f | 11 | | a3 : [] | d | h[
  a3 : NAp a4 c2
  a4 : NAp b3 c1
] | f | 12 | 13 | ## Rule 3 - If Rule 1 & Rule 2 Are Not Applicable 14 | | stack | dump | heap | globals | 15 | |-----------------------|--------------------|------------------------------------------------------------------------------------------------------------------------------------------|---------| 16 | | a : a1 : a2 : a3 : [] | d | h[
  a : NPrim NCaseList
  a1 : NAp a b1
  a2 : NAp a1 b2
  a3 : NAp a2 b3
] | f | 17 | | b1 : [] | (a1 : a2 : a3) : d | h | f | 18 | -------------------------------------------------------------------------------- /exercises/exercise2-25.md: -------------------------------------------------------------------------------- 1 | Users cannot define their own data type in their codes. 2 | -------------------------------------------------------------------------------- /exercises/exercise2-29.md: -------------------------------------------------------------------------------- 1 | Followings are disadvantages for data represented as a function 2 | 1. One cannot return list (or any other data type) as a result safely, since machine cannot distinguish it with a function. If you try to make a machine be able to return list, your machine will print a function too. 3 | 1. The performance is worse than the previous approach. 4 | 1. The method for defining data is not intuitive. 5 | 6 | Followings are advantages for data represented as a function 7 | 1. One don't need to implement separate primitives and steps for each data type. 8 | 1. User can define data without native support of the machine. 9 | -------------------------------------------------------------------------------- /exercises/exercise2-34.md: -------------------------------------------------------------------------------- 1 | ## Rule 1 2 | | forward | backward | heap | 3 | |---------|----------|----------------------------------| 4 | | f | b | h[f : NData t []] | 5 | | f | b | h[f : NMarked Done (NData t [])] | 6 | 7 | ## Rule 2 8 | | forward | backward | heap | 9 | |---------|----------|------------------------------------------| 10 | | f | b | h[f : NData t a:as] | 11 | | a | f | h[f : NMarked (Visits 1) (NData t b:as)] | 12 | 13 | ## Rule 3 14 | | forward | backward | heap | 15 | |-----------------|----------|----------------------------------------------------------------------------------------------------------------------------------------------------------------------| 16 | | f | b | h[
  f : NMarked Done n
  b : NMarked (Visits v) (NData t [a1,...,av-1,b',av+1,...am])
] | 17 | | av+1 | b | h[b : NMarked (Visits (v + 1)) (NData t [a1,...,av-1,f,b',...am])
])] | 18 | 19 | if v < m 20 | 21 | ## Rule 4 22 | | forward | backward | heap | 23 | |---------|----------|-------------------------------------------------------------------------------------------------------------------------------------| 24 | | f | b | h[
  f : NMarked Done n
  b : NMarked (Visits v) (NData t [a1,...,av-1,b'])
] | 25 | | b | b' | h[b : NMarked Done (NData t [a1,...,av-1,f])
])] | 26 | 27 | if v = m 28 | -------------------------------------------------------------------------------- /exercises/exercise3-01.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | 3 | Import ListNotations. 4 | 5 | Inductive a_expr := 6 | | Num : nat -> a_expr 7 | | Plus : a_expr -> a_expr -> a_expr 8 | | Mult : a_expr -> a_expr -> a_expr 9 | . 10 | 11 | Fixpoint a_interpret (e : a_expr) : nat := 12 | match e with 13 | | Num n => n 14 | | Plus e1 e2 => a_interpret e1 + a_interpret e2 15 | | Mult e1 e2 => a_interpret e1 * a_interpret e2 16 | end 17 | . 18 | 19 | Inductive a_instruction := 20 | | INum : nat -> a_instruction 21 | | IPlus : a_instruction 22 | | IMult : a_instruction 23 | . 24 | 25 | Fixpoint a_eval' (a_is : list a_instruction) (stk : list nat) : option nat := 26 | match a_is with 27 | | [] => 28 | match stk with 29 | | [n] => Some n 30 | | _ => None 31 | end 32 | | INum n :: a_is' => a_eval' a_is' (n :: stk) 33 | | IPlus :: a_is' => 34 | match stk with 35 | | n0 :: n1 :: stk' => a_eval' a_is' (n1 + n0 :: stk') 36 | | _ => None 37 | end 38 | | IMult :: a_is' => 39 | match stk with 40 | | n0 :: n1 :: stk' => a_eval' a_is' (n1 * n0 :: stk') 41 | | _ => None 42 | end 43 | end. 44 | 45 | Definition a_eval (state : list a_instruction * list nat) : option nat := 46 | match state with 47 | | (a_is, stk) => a_eval' a_is stk 48 | end 49 | . 50 | 51 | Fixpoint a_compile (e : a_expr) : list a_instruction := 52 | match e with 53 | | Num n => [INum n] 54 | | Plus e1 e2 => a_compile e1 ++ a_compile e2 ++ [IPlus] 55 | | Mult e1 e2 => a_compile e1 ++ a_compile e2 ++ [IMult] 56 | end 57 | . 58 | 59 | Lemma interpret_compile_equiv_general : forall (a_is : list a_instruction) (stk : list nat) (e : a_expr), 60 | a_eval (a_is, a_interpret e :: stk) = a_eval (a_compile e ++ a_is, stk) 61 | . 62 | Proof. 63 | intros; generalize dependent stk; generalize dependent a_is. 64 | induction e; intros; simpl; auto; try ( 65 | repeat rewrite app_assoc_reverse; 66 | unfold a_eval in IHe1; unfold a_eval in IHe2; 67 | rewrite <- IHe1; rewrite <- IHe2; now auto 68 | ). 69 | Qed. 70 | 71 | Theorem interpret_compile_equiv : forall (e : a_expr), 72 | Some (a_interpret e) = a_eval (a_compile e, []) 73 | . 74 | Proof. 75 | intros. 76 | replace (a_compile e) with (a_compile e ++ []); 77 | auto with datatypes. 78 | rewrite <- interpret_compile_equiv_general. 79 | now auto. 80 | Qed. 81 | -------------------------------------------------------------------------------- /exercises/exercise3-02.v: -------------------------------------------------------------------------------- 1 | Require Import Basics. 2 | Require Import DecBool. 3 | Require Import Nat. 4 | Require Import String. 5 | Require Import List. 6 | 7 | Import ListNotations. 8 | 9 | Inductive a_expr := 10 | | Num : nat -> a_expr 11 | | Plus : a_expr -> a_expr -> a_expr 12 | | Mult : a_expr -> a_expr -> a_expr 13 | | AVar : string -> a_expr 14 | | ALet : list (string * a_expr) -> a_expr -> a_expr 15 | . 16 | 17 | Definition a_int_env := list (string * nat). 18 | 19 | Fixpoint a_interpret' (e : a_expr) (env : a_int_env) : option nat := 20 | match e with 21 | | Num n => Some n 22 | | Plus e1 e2 => 23 | match (a_interpret' e1 env, a_interpret' e2 env) with 24 | | (Some n1, Some n2) => Some (n1 + n2) 25 | | _ => None 26 | end 27 | | Mult e1 e2 => 28 | match (a_interpret' e1 env, a_interpret' e2 env) with 29 | | (Some n1, Some n2) => Some (n1 * n2) 30 | | _ => None 31 | end 32 | | ALet bs bodyE => 33 | let b_folder := 34 | fun acc b => 35 | match a_interpret' (snd b) env with 36 | | Some n => ((compose (cons (fst b, n)) (fst acc)), snd acc) 37 | | _ => (fst acc, false) 38 | end 39 | in 40 | let (make_b_env, is_success) := fold_left b_folder bs (id, true) in 41 | if is_success 42 | then a_interpret' bodyE (make_b_env [] ++ env) 43 | else None 44 | | AVar id => 45 | match find (compose (eqb id) fst) env with 46 | | Some (_, n) => Some n 47 | | _ => None 48 | end 49 | end 50 | . 51 | 52 | Definition a_interpret (e : a_expr) : option nat := a_interpret' e []. 53 | 54 | Inductive a_instruction := 55 | | INum : nat -> a_instruction 56 | | IPlus : a_instruction 57 | | IMult : a_instruction 58 | | ICopy : nat -> a_instruction 59 | | ISlide : nat -> a_instruction 60 | | IFail : a_instruction 61 | . 62 | 63 | Definition a_stack := list nat. 64 | 65 | Fixpoint a_eval' (a_is : list a_instruction) (stk : a_stack) : option nat := 66 | match a_is with 67 | | [] => 68 | match stk with 69 | | [n] => Some n 70 | | _ => None 71 | end 72 | | INum n :: a_is' => a_eval' a_is' (n :: stk) 73 | | IPlus :: a_is' => 74 | match stk with 75 | | n0 :: n1 :: stk' => a_eval' a_is' (n1 + n0 :: stk') 76 | | _ => None 77 | end 78 | | IMult :: a_is' => 79 | match stk with 80 | | n0 :: n1 :: stk' => a_eval' a_is' (n1 * n0 :: stk') 81 | | _ => None 82 | end 83 | | ICopy i :: a_is' => 84 | match nth i (map Some stk) None with 85 | | Some n => a_eval' a_is' (n :: stk) 86 | | _ => None 87 | end 88 | | ISlide i :: a_is' => 89 | match stk with 90 | | n :: stk' => a_eval' a_is' (n :: skipn i stk') 91 | | _ => None 92 | end 93 | | IFail :: _ => None 94 | end. 95 | 96 | Definition a_eval (state : list a_instruction * list nat) : option nat := 97 | match state with 98 | | (a_is, stk) => a_eval' a_is stk 99 | end 100 | . 101 | 102 | Definition a_com_env := list (string * nat). 103 | 104 | Fixpoint env_offset (o : nat) (e : a_com_env) : a_com_env := 105 | match e with 106 | | [] => [] 107 | | (id, n) :: e' => (id, n + o) :: env_offset o e' 108 | end 109 | . 110 | 111 | Fixpoint a_compile' (e : a_expr) (env : a_com_env) : list a_instruction := 112 | match e with 113 | | Num n => [INum n] 114 | | Plus e1 e2 => a_compile' e1 env ++ a_compile' e2 (env_offset 1 env) ++ [IPlus] 115 | | Mult e1 e2 => a_compile' e1 env ++ a_compile' e2 (env_offset 1 env) ++ [IMult] 116 | | ALet bs eBody => 117 | let b_length := length bs in 118 | let b_folder := 119 | fun acc b => 120 | match acc with 121 | | (n, f) => (n - 1, a_compile' (snd b) (env_offset n env) ++ f) 122 | end in 123 | let b_is := snd (fold_left b_folder bs (b_length - 1, [])) in 124 | let b_env := combine (map fst bs) (rev (seq 0 b_length)) ++ (env_offset b_length env) in 125 | b_is ++ a_compile' eBody b_env ++ [ISlide b_length] 126 | | AVar id => 127 | match find (compose (eqb id) fst) env with 128 | | Some (_, i) => [ICopy i] 129 | | _ => [IFail] 130 | end 131 | end 132 | . 133 | 134 | Definition a_compile (e : a_expr) : list a_instruction := a_compile' e []. 135 | 136 | Definition int_env_to_com_env (int_env : a_int_env) : a_com_env := combine (map fst int_env) (rev (seq 0 (length int_env))). 137 | 138 | Definition int_env_to_stack (int_env : a_int_env) : a_stack := rev (map snd int_env). 139 | 140 | Definition com_env_stack_to_int_env (com_env : a_com_env) (stack : a_stack) : option a_int_env := 141 | let max_ind := fold_left max (map (compose (plus 1) snd) com_env) 0 in 142 | if max_ind <=? length stack 143 | then Some (map (fun b => (fst b, nth (snd b) stack 0)) com_env) 144 | else None 145 | . 146 | 147 | (* 148 | Lemma interpret_compile_equiv_general : forall (a_is : list a_instruction) (stk : a_stack) (e : a_expr), 149 | match a_interpret e with 150 | | Some n => a_eval (a_is, n :: stk) = a_eval (a_compile e ++ a_is, stk) 151 | | _ => True 152 | end 153 | . 154 | Proof. 155 | intros; generalize dependent stk; generalize dependent a_is. 156 | induction e; intros; simpl; try auto; 157 | try ( unfold a_interpret; unfold a_interpret in IHe1; unfold a_interpret in IHe2; simpl; 158 | destruct (a_interpret' e1 []); destruct (a_interpret' e2 []); auto; 159 | unfold a_compile; simpl; unfold a_eval in IHe1; unfold a_eval in IHe2; 160 | repeat rewrite app_assoc_reverse; rewrite <- IHe1; rewrite <- IHe2; now auto 161 | ). 162 | unfold a_interpret; unfold a_interpret in IHe; simpl. 163 | (* Need some lemma for `a_interpret e p` case *) 164 | Abort. 165 | *) 166 | 167 | (* 168 | Theorem interpret_compile_equiv : forall (e : a_expr), 169 | Some (a_interpret e) = a_eval (a_compile e, []) 170 | . 171 | Proof. 172 | intros. 173 | replace (a_compile e) with (a_compile e ++ []); 174 | auto with datatypes. 175 | rewrite <- interpret_compile_equiv_general. 176 | now auto. 177 | Qed. 178 | *) 179 | -------------------------------------------------------------------------------- /exercises/exercise3-03.md: -------------------------------------------------------------------------------- 1 | ``` 2 | compileSc ("S" ["f", "g", "x"], EAp (EAp (EVar "f") (EVar "x")) (EAp (EVar "g") (EVar "x"))) 3 | => ("S", 3, compileR (EAp (EAp (EVar "f") (EVar "x")) (EAp (EVar "g") (EVar "x"))) [("f", 0), ("g", 1), ("x", 2)]) 4 | => ("S", 3, compileC (EAp (EAp (EVar "f") (EVar "x")) (EAp (EVar "g") (EVar "x"))) [("f", 0), ("g", 1), ("x", 2)] ++ [Slide 4, Unwind]) 5 | => ("S", 3, compileC (EAp (EVar "f") (EVar "x")) [("f", 0), ("g", 1), ("x", 2)] ++ compileC (EAp (EVar "g") (EVar "x")) [("f", 1), ("g", 2), ("x", 3)] ++ [MkAp] ++ [Slide 4, Unwind]) 6 | => ("S", 3, compileC (EVar "f") [("f", 0), ("g", 1), ("x", 2)] ++ compileC (EVar "x") [("f", 1), ("g", 2), ("x", 3)] ++ [MkAp] ++ compileC (EAp (EVar "g") (EVar "x")) [("f", 1), ("g", 2), ("x", 3)] ++ [MkAp] ++ [Slide 4, Unwind]) 7 | => ("S", 3, [Push 0] ++ compileC (EVar "x") [("f", 1), ("g", 2), ("x", 3)] ++ [MkAp] ++ compileC (EAp (EVar "g") (EVar "x")) [("f", 1), ("g", 2), ("x", 3)] ++ [MkAp] ++ [Slide 4, Unwind]) 8 | => ("S", 3, [Push 0] ++ [Push 3] ++ [MkAp] ++ compileC (EAp (EVar "g") (EVar "x")) [("f", 1), ("g", 2), ("x", 3)] ++ [MkAp] ++ [Slide 4, Unwind]) 9 | => ("S", 3, [Push 0] ++ [Push 3] ++ [MkAp] ++ compileC (EVar "g") [("f", 1), ("g", 2), ("x", 3)] ++ compileC (EVar "x") [("f", 2), ("g", 3), ("x", 4)] ++ [MkAp] ++ [MkAp] ++ [Slide 4, Unwind]) 10 | => ("S", 3, [Push 0] ++ [Push 3] ++ [MkAp] ++ [Push 2] ++ compileC (EVar "x") [("f", 2), ("g", 3), ("x", 4)] ++ [MkAp] ++ [MkAp] ++ [Slide 4, Unwind]) 11 | => ("S", 3, [Push 0] ++ [Push 3] ++ [MkAp] ++ [Push 2] ++ [Push 4] ++ [MkAp] ++ [MkAp] ++ [Slide 4, Unwind]) 12 | => ("S", 3, [Push 0, Push 3, MkAp, Push 2, Push 4, MkAp, MkAp, Slide 4, Unwind]) 13 | ``` 14 | -------------------------------------------------------------------------------- /exercises/exercise3-04.md: -------------------------------------------------------------------------------- 1 | My G machine takes 28 steps where my template machine takes 8 steps. 2 | However, comparing their step count is not a fair way to compare them. 3 | In the G machine, a single step does not instantiate a single supercombinator, 4 | so it is simple and does not take long time. 5 | On the other hand, in the template machine, single step instantiate a single supercombinator, 6 | so it could be quite complex and take long time. 7 | -------------------------------------------------------------------------------- /exercises/exercise3-11.md: -------------------------------------------------------------------------------- 1 | Mark 1 G machine spent 63 steps to terminate the program, where Mark 2 G machine spent 81 steps. 2 | This is a fair comparison, because their steps have similar complexity with each other. 3 | 4 | Mark 2 G machine spent less steps when tested with a program that has repeated works. For example, with following program, Mark 2 spent 125 steps where Mark 1 spent 135 steps. 5 | 6 | ``` 7 | twice f x = f (f x); 8 | id x = x; 9 | main = twice twice (id (id (id (id id)))) 3 10 | ``` 11 | -------------------------------------------------------------------------------- /exercises/exercise3-17.core: -------------------------------------------------------------------------------- 1 | main = 2 | letrec 3 | a = K b; 4 | b = K1 a 5 | in 6 | a 3 (a 4 5) 7 | -------------------------------------------------------------------------------- /exercises/exercise3-19.compiled: -------------------------------------------------------------------------------- 1 | [("Y", 1, [Alloc 1, Push 0, Push 2, MkAp, Update 0, Update 1, Pop 1, Unwind])] 2 | -------------------------------------------------------------------------------- /exercises/exercise3-20.md: -------------------------------------------------------------------------------- 1 | One could define `Y` combinator like following. 2 | 3 | ``` 4 | Y f = f (Y f) 5 | ``` 6 | 7 | After compilation, it becomes 8 | 9 | ``` 10 | [("Y", 1, [Push 0, PushGlobal "Y", MkAp, Push 1, MkAp, Update 1, Pop 1, Unwind])] 11 | ``` 12 | 13 | However, with this definition, the machine need to spend more steps since it always re-instantiate `Y` combinator when its argument is evaluated. 14 | -------------------------------------------------------------------------------- /exercises/exercise3-24.md: -------------------------------------------------------------------------------- 1 | Because **Unwind** will unwind indirection to number node. 2 | -------------------------------------------------------------------------------- /exercises/exercise3-26.md: -------------------------------------------------------------------------------- 1 | If there is nothing like following code, 2 | 3 | ``` 4 | case getDump state of 5 | (c, as') : dump' -> putDump dump' (putCode c (putStack (a : as') state)) 6 | _ -> state 7 | 8 | ``` 9 | 10 | one should update `initialCode` since **Unwind** cannot handle empty dump. 11 | 12 | However, with the code, **Unwind** works well with `main` and you don't need to update `initialCode`. 13 | -------------------------------------------------------------------------------- /exercises/exercise3-29.core: -------------------------------------------------------------------------------- 1 | f = negate; 2 | main = f 5 3 | -------------------------------------------------------------------------------- /exercises/exercise3-45.md: -------------------------------------------------------------------------------- 1 | One needs to change *B* scheme to generate optimised code for `&`, `|`, `not`. 2 | -------------------------------------------------------------------------------- /exercises/exercise3-47.md: -------------------------------------------------------------------------------- 1 | ## Rule for UpdateInt 2 | | output | code | stack | dump | vStack | heap | globals | 3 | |--------|-----------------|-------------------|------|--------|----------------|---------| 4 | | o | UpdateInt n : i | a0 : ... : an : s | d | n : v | h | m | 5 | | o | i | a0 : ... : an : s | d | v | h[an : NNum n] | m | 6 | 7 | ## Rule for UpdateBool 8 | | output | code | stack | dump | vStack | heap | globals | 9 | |--------|------------------|-------------------|------|--------|----------------------|---------| 10 | | o | UpdateBool n : i | a0 : ... : an : s | d | t : v | h | m | 11 | | o | i | a0 : ... : an : s | d | v | h[an : NConstr t []] | m | 12 | -------------------------------------------------------------------------------- /exercises/exercise4-09.md: -------------------------------------------------------------------------------- 1 | It cannot detect comparison mode in the following program, 2 | and it is not able to run. 3 | 4 | ``` 5 | multipleof3 x = ((x / 3) * 3) == x 6 | f y = if (multipleof3 y) 0 1 7 | ``` 8 | -------------------------------------------------------------------------------- /exercises/exercise4-10.md: -------------------------------------------------------------------------------- 1 | # Rule for Take 2 | | Instructions | Frame Pointer | Stack | Value Stack | Heap | Code Store | 3 | |--------------|---------------|-------------------|-------------|----------------------------------------------------|------------| 4 | | Take t n : i | f | c1 : ... : cn : s | v | h | c | 5 | | i | f' | s | v | h[f' : ] | c | 6 | 7 | where `f'` repeats `([], null)` `t - n` times. 8 | 9 | # Rule 1 for Move 10 | 11 | | Instructions | Frame Pointer | Stack | Value Stack | Heap | Code Store | 12 | |--------------------|---------------|-------|-------------|----------------------------------------------------------------|------------| 13 | | Move n (Arg k) : i | f | s | v | h[f : <(i1, f1), ..., (ik, fk), ..., (in, fn), ..., (im, fm)>] | c | 14 | | i | f | s | v | h[f : <(i1, f1), ..., (ik, fk), ..., (ik, fk), ..., (im, fm)>] | c | 15 | 16 | # Rule 2 for Move 17 | 18 | | Instructions | Frame Pointer | Stack | Value Stack | Heap | Code Store | 19 | |----------------------|---------------|-------|-------------|-------------------------------------------------|------------| 20 | | Move n (Label l) : i | f | s | v | h[f : <(i1, f1), ..., (in, fn), ..., (im, fm)>] | c[l : i'] | 21 | | i | f | s | v | h[f : <(i1, f1), ..., (i', f), ..., (im, fm)>] | c | 22 | 23 | # Rule 3 for Move 24 | 25 | | Instructions | Frame Pointer | Stack | Value Stack | Heap | Code Store | 26 | |----------------------|---------------|-------|-------------|---------------------------------------------------------|------------| 27 | | Move n (Code i') : i | f | s | v | h[f : <(i1, f1), ..., (in, fn), ..., (im, fm)>] | c | 28 | | i | f | s | v | h[f : <(i1, f1), ..., (i', f), ..., (im, fm)>] | c | 29 | 30 | # Rule 4 for Move 31 | 32 | | Instructions | Frame Pointer | Stack | Value Stack | Heap | Code Store | 33 | |-------------------------|---------------|-------|-------------|-----------------------------------------------------|------------| 34 | | Move n (IntConst n) : i | f | s | v | h[f : <(i1, f1), ..., (in, fn), ..., (im, fm)>] | c | 35 | | i | f | s | v | h[f : <(i1, f1), ..., (intCode, n), ..., (im, fm)>] | c | 36 | -------------------------------------------------------------------------------- /exercises/exercise4-12.md: -------------------------------------------------------------------------------- 1 | The one with `let` allocates less frames since there are less `Enter` instructions. 2 | -------------------------------------------------------------------------------- /exercises/exercise5-04.md: -------------------------------------------------------------------------------- 1 | If we don't spark new task until first argument of `par` becomes WHNF, two arguments of `par` will not be executed parallelly, since second should wait first one. 2 | -------------------------------------------------------------------------------- /exercises/exercise5-06.md: -------------------------------------------------------------------------------- 1 | ``` 2 | main = par (S K K) (S K K 3) 3 | ``` 4 | 5 | takes 49 steps where 6 | 7 | ``` 8 | main = S K K (S K K 3) 9 | ``` 10 | 11 | takes 73 steps. 12 | -------------------------------------------------------------------------------- /exercises/exercise5-07.md: -------------------------------------------------------------------------------- 1 | In the following program, using `par` is justified, since it helps to evaluate `I 3` during unwiding `I`. 2 | 3 | ``` 4 | main = par I (I 3) 5 | ``` 6 | 7 | -------------------------------------------------------------------------------- /exercises/exercise5-10.md: -------------------------------------------------------------------------------- 1 | ``` 2 | main = twicePar (twicePar (twicePar (S K K))) 3; 3 | twicePar f x = par f (f x) 4 | ``` 5 | 6 | does not work with Mark 2 implementation. 7 | That is because when a node is unlocked, only single task among blocked tasks can be resumed, and the resumed can be depends on a blocked task (which should be resumed). 8 | -------------------------------------------------------------------------------- /exercises/exercise5-11.md: -------------------------------------------------------------------------------- 1 | It takes `ceil(30 * 85 * log_2(10))`, i.e., 8471 ticks. 2 | -------------------------------------------------------------------------------- /exercises/exercise5-12.md: -------------------------------------------------------------------------------- 1 | It takes `ceil(30 * (13 * log_2(10) - 1))`, i.e., 1266 ticks. 2 | -------------------------------------------------------------------------------- /exercises/exercise6-13.v: -------------------------------------------------------------------------------- 1 | Require Import Relations. 2 | 3 | Theorem same_clos_same : forall {A : Type} R S, 4 | same_relation A R S -> 5 | same_relation A (clos_refl_trans_1n A R) (clos_refl_trans_1n A S). 6 | Proof. 7 | intros; inversion_clear H as [HRS HSR]; 8 | split; intros x y Hxy; 9 | induction Hxy; try (now constructor); 10 | constructor 2 with y; now auto. 11 | Qed. 12 | 13 | Theorem clos_refl_trans_1n_reverse : forall A R x y z, 14 | clos_refl_trans_1n A R x y -> 15 | R y z -> 16 | clos_refl_trans_1n A R x z. 17 | Proof. 18 | intros. 19 | induction H; intros. 20 | - constructor 2 with z; auto; now constructor. 21 | - constructor 2 with y; auto. 22 | Qed. 23 | 24 | Theorem clos_refl_trans_1n_transp_permute : forall A R x y, 25 | transp A (clos_refl_trans_1n A R) x y <-> clos_refl_trans_1n A (transp A R) x y. 26 | Proof. 27 | intros; split; intros; 28 | unfold transp in H; 29 | induction H; try (now constructor); 30 | apply clos_refl_trans_1n_reverse with y; auto. 31 | Qed. 32 | 33 | Definition DiGraph (V : Set) := V -> V -> bool. 34 | 35 | Definition dg_outs {V : Set} (gr : DiGraph V) : relation V := 36 | fun (v v' : V) => gr v v' = true. 37 | Definition dg_ins {V : Set} (gr : DiGraph V) : relation V := 38 | fun (v v' : V) => gr v' v = true. 39 | 40 | Definition dg_outs_star {V : Set} (gr : DiGraph V) := clos_refl_trans_1n V (dg_outs gr). 41 | Definition dg_ins_star {V : Set} (gr : DiGraph V) := clos_refl_trans_1n V (dg_ins gr). 42 | 43 | Definition dg_scc {V : Set} (gr : DiGraph V) : relation V := fun x y => dg_outs_star gr x y /\ dg_ins_star gr x y. 44 | 45 | Definition in_the_same_scc {V : Set} (gr : DiGraph V) : relation V := 46 | fun (v v' : V) => exists (a : V), dg_scc gr a v /\ dg_scc gr a v'. 47 | 48 | 49 | Lemma dg_ins__equiv__trasp_dg_outs : forall {V : Set} gr, 50 | same_relation V (dg_ins gr) (transp V (dg_outs gr)). 51 | Proof. 52 | intros; split; intros x y Hxy; now auto. 53 | Qed. 54 | 55 | Lemma dg_ins_star_transitive : forall {V : Set} gr, 56 | transitive V (dg_ins_star gr). 57 | Proof. 58 | intros. intros x y z Hxy Hyz. 59 | generalize dependent z. 60 | induction Hxy as [x | x y v]; try (now auto). 61 | intros z Hvz. 62 | constructor 2 with y; auto. 63 | apply IHHxy. apply Hvz. 64 | Qed. 65 | 66 | Lemma dg_outs_star_transitive : forall {V : Set} gr, 67 | transitive V (dg_outs_star gr). 68 | Proof. 69 | intros. intros x y z Hxy Hyz. 70 | generalize dependent z. 71 | induction Hxy as [x | x y v]; try (now auto). 72 | intros z Hvz. 73 | constructor 2 with y; auto. 74 | apply IHHxy. apply Hvz. 75 | Qed. 76 | 77 | Theorem in_the_same_scc_reflexive : forall {V : Set} gr, 78 | reflexive V (in_the_same_scc gr). 79 | Proof. 80 | intros; intro x. 81 | exists x; now (repeat constructor). 82 | Qed. 83 | 84 | Theorem in_the_same_scc_symmetric : forall {V : Set} gr, 85 | symmetric V (in_the_same_scc gr). 86 | Proof. 87 | intros; intros x y H. 88 | inversion_clear H as [v Hv]. 89 | inversion_clear Hv as [Hx Hy]. 90 | inversion_clear Hx as [Hxouts Hxins]. 91 | inversion_clear Hy as [Hyouts Hyins]. 92 | exists v; split; split; now auto. 93 | Qed. 94 | 95 | Theorem in_the_same_scc_transitive : forall {V : Set} gr, 96 | transitive V (in_the_same_scc gr). 97 | Proof. 98 | intros; intros x y z Hxy Hyz. 99 | enough (HDG : (forall a b, dg_ins_star gr a b -> dg_outs_star gr b a) /\ (forall a b, dg_outs_star gr a b -> dg_ins_star gr b a)). 100 | destruct HDG. 101 | - inversion_clear Hxy as [vxy Hvxy]. 102 | inversion_clear Hvxy as [Hvxyx Hvxyy]. 103 | inversion_clear Hvxyx as [Hvxyxout Hvxyxin]. 104 | inversion_clear Hvxyy as [Hvxyyout Hvxyyin]. 105 | inversion_clear Hyz as [vyz Hvyz]. 106 | inversion_clear Hvyz as [Hvyzy Hvyzz]. 107 | inversion_clear Hvyzy as [Hvyzyout Hvyzyin]. 108 | inversion_clear Hvyzz as [Hvyzzout Hvyzzin]. 109 | exists y; split; 110 | (split; [eapply dg_outs_star_transitive; swap 1 2 | eapply dg_ins_star_transitive; swap 1 2]); 111 | now eauto. 112 | - destruct (same_clos_same (dg_ins gr) (transp V (dg_outs gr)) (dg_ins__equiv__trasp_dg_outs gr)). 113 | split; intros; 114 | [replace (dg_outs_star gr b a) with (transp V (dg_outs_star gr) a b) | 115 | replace (dg_outs_star gr a b) with (transp V (dg_outs_star gr) b a) in H1]; auto; 116 | unfold inclusion in H; 117 | apply clos_refl_trans_1n_transp_permute; auto. 118 | Qed. 119 | 120 | Lemma in_the_same_scc_equiv : forall {V : Set} gr, 121 | equiv V (in_the_same_scc gr). 122 | Proof. 123 | intros; repeat (try split); 124 | try apply in_the_same_scc_reflexive; 125 | try apply in_the_same_scc_symmetric; 126 | try apply in_the_same_scc_transitive. 127 | Qed. 128 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | spec-version: 0.31.0 2 | name: core-lang-haskell 3 | version: 0.1.0.0 4 | #synopsis: 5 | #description: 6 | category: Web 7 | homepage: https://github.com/Ailrun/core-lang-haskell#readme 8 | bug-reports: https://github.com/Ailrun/core-lang-haskell/issues 9 | author: Junyoung Clare Jang 10 | maintainer: jjc9310@gmail.com 11 | copyright: 2019 Junyoung Clare Jang 12 | license: BSD3 13 | license-file: LICENSE 14 | #tested-with: 15 | #build-type: Simple 16 | extra-source-files: 17 | - README.md 18 | #extra-doc-files: 19 | data-files: "examples/**/*" 20 | #data-dir: 21 | github: Ailrun/core-lang-haskell 22 | #custom-setup: 23 | #dependencies: 24 | 25 | #flags: 26 | 27 | library: 28 | ## Common fields 29 | source-dirs: 30 | - src 31 | cpp-options: 32 | - -D__CLH_EXERCISE_1__=100 33 | - -D__CLH_EXERCISE_2__=100 34 | - -D__CLH_EXERCISE_3__=100 35 | - -D__CLH_EXERCISE_4__=100 36 | - -D__CLH_EXERCISE_5__=100 37 | - -D__CLH_EXERCISE_6__=100 38 | ## Library fields 39 | #exposed: 40 | #exposed-modules: 41 | #generated-exposed-modules: 42 | #other-modules: 43 | #generated-other-modules: 44 | #reexported-modules: 45 | #signatures: 46 | 47 | #internal-libraries: 48 | 49 | executables: 50 | core-lang-haskell: 51 | ## Common fields 52 | source-dirs: 53 | - app 54 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 55 | dependencies: 56 | - core-lang-haskell 57 | ## Executable fields 58 | main: Main.hs 59 | #other-modules: 60 | #generated-other-modules: 61 | 62 | #executable: 63 | 64 | tests: 65 | core-lang-haskell-test: 66 | ## Common fields 67 | source-dirs: 68 | - test 69 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 70 | dependencies: 71 | # Test target 72 | - core-lang-haskell 73 | # Test tools 74 | - hspec 75 | - QuickCheck 76 | # Other utils 77 | - directory 78 | - filepath 79 | ## Test fields 80 | main: Spec.hs 81 | #other-modules: 82 | #generated-other-modules: 83 | 84 | #benchmarks: 85 | 86 | #defaults: 87 | #github: 88 | #ref: 89 | #path: 90 | #local: 91 | 92 | ## Common fields 93 | #buildable: 94 | #source-dirs: 95 | #default-extensions: 96 | #other-extensions: 97 | #ghc-options: 98 | #ghc-prof-options: 99 | #ghcjs-options: 100 | #cpp-options: 101 | #cc-options: 102 | #c-sources: 103 | #cxx-options: 104 | #cxx-sources: 105 | #js-sources: 106 | #extra-lib-dirs: 107 | #extra-libraries: 108 | #include-dirs: 109 | #install-includes: 110 | #frameworks: 111 | #extra-frameworks-dirs: 112 | #ld-options: 113 | dependencies: 114 | - base >= 4.7 && < 5 115 | #pkg-config-dependencies: 116 | #build-tools: 117 | #system-build-tools: 118 | #when: 119 | -------------------------------------------------------------------------------- /src/Data/ISeq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Data.ISeq where 3 | 4 | import Prelude hiding ( seq ) 5 | 6 | import Data.List 7 | import Util 8 | 9 | iNil :: ISeq 10 | iStr :: String -> ISeq 11 | iAppend :: ISeq -> ISeq -> ISeq 12 | iNewline :: ISeq 13 | iIndent :: ISeq -> ISeq 14 | iDisplay :: ISeq -> String 15 | 16 | #if __CLH_EXERCISE_1__ >= 2 17 | iConcat :: [ISeq] -> ISeq 18 | iConcat = foldr iAppend iNil 19 | 20 | iInterleave :: ISeq -> [ISeq] -> ISeq 21 | iInterleave sep seqs = foldr iAppend iNil (intersperse sep seqs) 22 | 23 | #if __CLH_EXERCISE_1__ < 6 24 | data ISeq 25 | = INil 26 | | IStr String 27 | | IAppend ISeq ISeq 28 | #endif 29 | 30 | iNil = INil 31 | 32 | #if __CLH_EXERCISE_1__ < 7 33 | iStr = IStr 34 | #endif 35 | 36 | #if __CLH_EXERCISE_1__ != 5 37 | iAppend = IAppend 38 | #endif 39 | 40 | #if __CLH_EXERCISE_1__ == 5 41 | iAppend INil seq2 = seq2 42 | iAppend seq1 INil = seq1 43 | iAppend seq1 seq2 = IAppend seq1 seq2 44 | #endif 45 | 46 | #if __CLH_EXERCISE_1__ < 6 47 | iIndent seq = seq 48 | iNewline = IStr "\n" 49 | 50 | flatten :: [ISeq] -> String 51 | 52 | iDisplay = flatten . return 53 | 54 | flatten [] = "" 55 | flatten (INil : seqs) = flatten seqs 56 | flatten (IStr s : seqs) = s ++ flatten seqs 57 | flatten (IAppend seq1 seq2 : seqs) = flatten (seq1 : seq2 : seqs) 58 | #endif 59 | 60 | #if __CLH_EXERCISE_1__ >= 6 61 | data ISeq 62 | = INil 63 | | IStr String 64 | | IAppend ISeq ISeq 65 | | IIndent ISeq 66 | | INewline 67 | 68 | iIndent = IIndent 69 | 70 | iNewline = INewline 71 | 72 | flatten :: Int -> [(ISeq, Int)] -> String 73 | 74 | iDisplay seq = flatten 0 [(seq, 0)] 75 | 76 | flatten _ ((INewline, indent) : seqs) 77 | = '\n' : space indent ++ flatten indent seqs 78 | flatten col ((IIndent seq, _) : seqs) 79 | = flatten col ((seq, col) : seqs) 80 | flatten col ((IAppend seq1 seq2, indent) : seqs) 81 | = flatten col ((seq1, indent) : (seq2, indent) : seqs) 82 | flatten col ((IStr s, _) : seqs) = s ++ flatten (col + length s) seqs 83 | flatten col ((INil, _) : seqs) = flatten col seqs 84 | flatten _ [] = "" 85 | 86 | #if __CLH_EXERCISE_1__ >= 7 87 | iStr = iConcat . intersperse INewline . map IStr . lines 88 | #endif 89 | 90 | #if __CLH_EXERCISE_1__ >= 8 91 | iPrecParen :: Int -> Int -> ISeq -> ISeq 92 | iPrecParen contextPrec currentPrec seq 93 | | contextPrec > currentPrec = iConcat [ iStr "(", seq, iStr ")" ] 94 | | otherwise = seq 95 | 96 | iNum :: Int -> ISeq 97 | iNum = iStr . show 98 | 99 | iFWNum :: Int -> Int -> ISeq 100 | iFWNum width n 101 | = iStr (space (width - length digits) ++ digits) 102 | where 103 | digits = show n 104 | 105 | -- | 106 | -- This function is named after the similar function of the Miranda 107 | iLayn :: [ISeq] -> ISeq 108 | iLayn seqs 109 | = iConcat (zipWith layItem [1..] seqs) 110 | where 111 | layItem n seq 112 | = iConcat [ iFWNum 4 n, iStr ") ", iIndent seq, iNewline ] 113 | #endif 114 | #endif 115 | #else 116 | data ISeq 117 | 118 | iNil = undefined 119 | iStr = undefined 120 | iAppend = undefined 121 | iNewline = undefined 122 | iIndent = undefined 123 | iDisplay = undefined 124 | #endif 125 | -------------------------------------------------------------------------------- /src/Data/StatHeap.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- This module is for exercise 2.7 3 | module Data.StatHeap 4 | ( statHInitial 5 | , statHAlloc 6 | , statHUpdate 7 | , statHFree 8 | , statHLookup 9 | , statHAddresses 10 | , statHSize 11 | , statHNull 12 | , statHIsNull 13 | , statHGetStats 14 | , StatHeap 15 | 16 | , statHSInitial 17 | , statHSIncHAlloc 18 | , statHSGetHAlloc 19 | , statHSIncHUpdate 20 | , statHSGetHUpdate 21 | , statHSIncHFree 22 | , statHSGetHFree 23 | , StatHeapStats 24 | 25 | , Addr 26 | ) 27 | where 28 | 29 | import Util 30 | 31 | statHInitial :: StatHeap a 32 | statHInitial = (hInitial, statHSInitial) 33 | 34 | statHAlloc :: StatHeap a -> a -> (StatHeap a, Addr) 35 | statHAlloc (heap, stats) n = ((heap', statHSIncHAlloc stats), addr) 36 | where 37 | (heap', addr) = hAlloc heap n 38 | 39 | statHUpdate :: StatHeap a -> Addr -> a -> StatHeap a 40 | statHUpdate (heap, stats) addr a = (hUpdate heap addr a, statHSIncHUpdate stats) 41 | 42 | statHFree :: StatHeap a -> Addr -> StatHeap a 43 | statHFree (heap, stats) addr = (hFree heap addr, statHSIncHFree stats) 44 | 45 | statHLookup :: StatHeap a -> Addr -> a 46 | statHLookup (heap, _) = hLookup heap 47 | 48 | statHAddresses :: StatHeap a -> [Addr] 49 | statHAddresses (heap, _) = hAddresses heap 50 | 51 | statHSize :: StatHeap a -> Int 52 | statHSize (heap, _) = hSize heap 53 | 54 | statHNull :: Addr 55 | statHNull = 0 56 | 57 | statHIsNull :: Addr -> Bool 58 | statHIsNull = (== hNull) 59 | 60 | statHGetStats :: StatHeap a -> StatHeapStats 61 | statHGetStats (_, stats) = stats 62 | 63 | type StatHeap a 64 | = (Heap a, StatHeapStats) 65 | 66 | statHSInitial :: StatHeapStats 67 | statHSInitial = (0, 0, 0) 68 | 69 | statHSIncHAlloc :: StatHeapStats -> StatHeapStats 70 | statHSIncHAlloc (a, u, f) = (a + 1, u, f) 71 | 72 | statHSGetHAlloc :: StatHeapStats -> Int 73 | statHSGetHAlloc (a, _, _) = a 74 | 75 | statHSIncHUpdate :: StatHeapStats -> StatHeapStats 76 | statHSIncHUpdate (a, u, f) = (a, u + 1, f) 77 | 78 | statHSGetHUpdate :: StatHeapStats -> Int 79 | statHSGetHUpdate (_, u, _) = u 80 | 81 | statHSIncHFree :: StatHeapStats -> StatHeapStats 82 | statHSIncHFree (a, u, f) = (a, u, f + 1) 83 | 84 | statHSGetHFree :: StatHeapStats -> Int 85 | statHSGetHFree (_, _, f) = f 86 | 87 | type StatHeapStats 88 | = ( Int -- The number of heap allocations 89 | , Int -- The number of heap updates 90 | , Int -- The number of heap frees 91 | ) 92 | -------------------------------------------------------------------------------- /src/Language/LambdaLifting.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Language.LambdaLifting 3 | ( lambdaRun 4 | , lambdaLift 5 | , runS 6 | #if __CLH_EXERCISE_6__ >= 7 7 | , lambdaRunJ 8 | , lambdaLiftJ 9 | , runJ 10 | #if __CLH_EXERCISE_6__ >= 9 11 | , lambdaRunF 12 | , fullyLazyLift 13 | , runF 14 | #if __CLH_EXERCISE_6__ >= 16 15 | , lambdaRunD 16 | , dependency 17 | , runD 18 | #endif 19 | #endif 20 | #endif 21 | ) 22 | where 23 | 24 | import Control.Arrow 25 | import Data.List 26 | import Language.Parser 27 | import Language.PrettyPrinter 28 | import Language.Types 29 | import Util 30 | 31 | lambdaRun = putStrLn . runS 32 | 33 | lambdaLift :: CoreProgram -> CoreProgram 34 | 35 | freeVars :: CoreProgram -> AnnProgram Name (Set Name) 36 | 37 | abstract :: AnnProgram Name (Set Name) -> CoreProgram 38 | 39 | rename :: CoreProgram -> CoreProgram 40 | 41 | collectScs :: CoreProgram -> CoreProgram 42 | 43 | lambdaLift = collectScs . rename . abstract . freeVars 44 | 45 | runS = prettyPrint . lambdaLift . parse 46 | 47 | freeVars program 48 | = [ (name, args, freeVarsE (setFromList args) body) 49 | | (name, args, body) <- program 50 | ] 51 | 52 | freeVarsE :: Set Name -> CoreExpr -> AnnExpr Name (Set Name) 53 | freeVarsE _ (ENum k) = (setEmpty, ANum k) 54 | freeVarsE lv (EVar v) 55 | | setElementOf v lv = (setSingleton v, AVar v) 56 | | otherwise = (setEmpty, AVar v) 57 | freeVarsE lv (EAp e1 e2) 58 | = (setUnion (freeVarsOf e1') (freeVarsOf e2'), AAp e1' e2') 59 | where 60 | e1' = freeVarsE lv e1 61 | e2' = freeVarsE lv e2 62 | freeVarsE lv (ELam args body) 63 | = (setSubtraction (freeVarsOf body') (setFromList args), ALam args body') 64 | where 65 | body' = freeVarsE newLv body 66 | newLv = setUnion lv (setFromList args) 67 | freeVarsE lv (ELet isRec defns body) 68 | = (setUnion defnsFree bodyFree, ALet isRec defns' body') 69 | where 70 | binders = bindersOf defns 71 | binderSet = setFromList binders 72 | bodyLv = setUnion lv binderSet 73 | rhsLv 74 | | isRec = bodyLv 75 | | otherwise = lv 76 | 77 | rhss' = map (freeVarsE rhsLv) (rhssOf defns) 78 | defns' = zip binders rhss' 79 | freeInRhss = setUnionList (map freeVarsOf rhss') 80 | defnsFree 81 | | isRec = setSubtraction freeInRhss binderSet 82 | | otherwise = freeInRhss 83 | body' = freeVarsE bodyLv body 84 | bodyFree = setSubtraction (freeVarsOf body') binderSet 85 | freeVarsE lv (ECase e alts) = freeVarsCase lv e alts 86 | freeVarsE _ (EConstr t a) = (setEmpty, AConstr t a) 87 | 88 | freeVarsCase :: Set Name -> CoreExpr -> [CoreAlter] -> AnnExpr Name (Set Name) 89 | #if __CLH_EXERCISE_6__ < 4 90 | freeVarsCase lv e alts = error "freeVarsCase: not yet implemented" 91 | #endif 92 | 93 | freeVarsOf :: AnnExpr Name (Set Name) -> Set Name 94 | freeVarsOf (fvs, expr) = fvs 95 | 96 | freeVarsOfAlter :: AnnAlter Name (Set Name) -> Set Name 97 | freeVarsOfAlter (tag, args, rhs) 98 | = setSubtraction (freeVarsOf rhs) (setFromList args) 99 | 100 | abstract program 101 | = [ (scName, args, abstractE rhs) 102 | | (scName, args, rhs) <- program 103 | ] 104 | 105 | abstractE :: AnnExpr Name (Set Name) -> CoreExpr 106 | abstractE (_, ANum n) = ENum n 107 | abstractE (_, AVar v) = EVar v 108 | abstractE (_, AAp e1 e2) = EAp (abstractE e1) (abstractE e2) 109 | abstractE (_, ALet isRec defns body) 110 | = ELet isRec (map (second abstractE) defns) (abstractE body) 111 | abstractE (free, ALam args body) 112 | = foldl EAp sc (map EVar fvs) 113 | where 114 | fvs = setToList free 115 | sc = ELet nonRecursive [("sc", scRhs)] (EVar "sc") 116 | scRhs = ELam (fvs ++ args) (abstractE body) 117 | abstractE (_, AConstr t a) = EConstr t a 118 | abstractE (free, ACase e alts) = abstractCase free e alts 119 | 120 | abstractCase :: Set Name -> AnnExpr Name (Set Name) -> [AnnAlter Name (Set Name)] -> CoreExpr 121 | #if __CLH_EXERCISE_6__ < 4 122 | abstractCase free e alts = error "abstractCase: not yet implemented" 123 | #endif 124 | 125 | #if __CLH_EXERCISE_6__ < 9 126 | rename = snd . mapAccumL renameSc initialNameSupply 127 | where 128 | renameSc ns (scName, args, rhs) 129 | = (ns2, (scName, args', rhs')) 130 | where 131 | (ns1, args', env) = newNames ns args 132 | (ns2, rhs') = renameE env ns1 rhs 133 | #endif 134 | 135 | newNames :: NameSupply -> [Name] -> (NameSupply, [Name], Assoc Name Name) 136 | newNames ns oldNames 137 | = (ns', newNames, env) 138 | where 139 | (ns', newNames) = getNames ns oldNames 140 | env = zip oldNames newNames 141 | 142 | renameE :: Assoc Name Name -> NameSupply -> CoreExpr -> (NameSupply, CoreExpr) 143 | renameE _ ns (ENum n) = (ns, ENum n) 144 | renameE env ns (EVar v) = (ns, EVar (aLookup env v v)) 145 | renameE env ns (EAp e1 e2) 146 | = (ns2, EAp e1' e2') 147 | where 148 | (ns1, e1') = renameE env ns e1 149 | (ns2, e2') = renameE env ns1 e2 150 | renameE env ns (ELam args body) 151 | = (ns2, ELam args' body') 152 | where 153 | (ns1, args', env') = newNames ns args 154 | (ns2, body') = renameE (env' ++ env) ns1 body 155 | renameE env ns (ELet isRec defns body) 156 | = (ns3, ELet isRec (zip binders' rhss') body') 157 | where 158 | (ns1, body') = renameE bodyEnv ns body 159 | binders = bindersOf defns 160 | (ns2, binders', env') = newNames ns1 binders 161 | bodyEnv = env' ++ env 162 | (ns3, rhss') = mapAccumL (renameE rhsEnv) ns2 (rhssOf defns) 163 | rhsEnv 164 | | isRec = bodyEnv 165 | | otherwise = env 166 | renameE env ns (EConstr t a) = (ns, EConstr t a) 167 | renameE env ns (ECase e alts) = renameCase env ns e alts 168 | 169 | renameCase :: Assoc Name Name -> NameSupply -> CoreExpr -> [CoreAlter] -> (NameSupply, CoreExpr) 170 | #if __CLH_EXERCISE_6__ < 4 171 | renameCase env ns e alts = error "renameCase: not yet implemented" 172 | #endif 173 | 174 | #if __CLH_EXERCISE_6__ < 5 175 | collectScs = concatMap collectOneSc 176 | where 177 | collectOneSc (scName, args, rhs) 178 | = (scName, args, rhs') : scs 179 | where 180 | (scs, rhs') = collectScsE rhs 181 | #endif 182 | 183 | collectScsE :: CoreExpr -> ([CoreScDefn], CoreExpr) 184 | #if __CLH_EXERCISE_6__ < 6 185 | collectScsE (ENum n) = ([], ENum n) 186 | collectScsE (EVar v) = ([], EVar v) 187 | collectScsE (EAp e1 e2) = (scs1 ++ scs2, EAp e1' e2') 188 | where 189 | (scs1, e1') = collectScsE e1 190 | (scs2, e2') = collectScsE e2 191 | collectScsE (ELam args body) = second (ELam args) (collectScsE body) 192 | collectScsE (ELet isRec defns body) 193 | = (rhssScs ++ bodyScs ++ localScs, mkELet isRec nonScs' body') 194 | where 195 | (rhssScs, defns') = mapAccumL collectScsD [] defns 196 | 197 | scs' = filter (isELam . snd) defns' 198 | nonScs' = filter (not . isELam . snd) defns' 199 | localScs 200 | = [ (name, args, body) 201 | | (name, ELam args body) <- scs' 202 | ] 203 | 204 | (bodyScs, body') = collectScsE body 205 | 206 | collectScsD scs (name, rhs) = ((scs ++) *** (,) name) (collectScsE rhs) 207 | collectScsE (EConstr t a) = ([], EConstr t a) 208 | collectScsE (ECase e alts) 209 | = (scsE ++ scsAlts, ECase e' alts') 210 | where 211 | (scsE, e') = collectScsE e 212 | (scsAlts, alts') = mapAccumL collectScsAlt [] alts 213 | 214 | collectScsAlt scs (tag, args, rhs) 215 | = ((scs ++) *** (,,) tag args) (collectScsE rhs) 216 | #endif 217 | 218 | isELam :: Expr a -> Bool 219 | isELam (ELam _ _) = True 220 | isELam _ = False 221 | 222 | mkELet :: IsRec -> Assoc a (Expr a) -> Expr a -> Expr a 223 | #if __CLH_EXERCISE_6__ < 3 224 | mkELet = ELet 225 | #endif 226 | 227 | #if __CLH_EXERCISE_6__ >= 3 228 | mkELet _ [] body = body 229 | mkELet isRec defns body = ELet isRec defns body 230 | 231 | #if __CLH_EXERCISE_6__ >= 4 232 | freeVarsCase lv e alts 233 | = (setUnion eFree altsFree, ACase e' alts') 234 | where 235 | e' = freeVarsE lv e 236 | alts' = map freeVarsAlter alts 237 | 238 | eFree = freeVarsOf e' 239 | altsFree = setUnionList (map freeVarsOfAlter alts') 240 | 241 | freeVarsAlter (tag, args, rhs) = (tag, args, freeVarsE rhsLv rhs) 242 | where 243 | rhsLv = setUnion argSet lv 244 | argSet = setFromList args 245 | 246 | abstractCase free e alts = ECase (abstractE e) (map abstractAlter alts) 247 | 248 | abstractAlter :: AnnAlter Name (Set Name) -> CoreAlter 249 | abstractAlter (tag, args, rhs) = (tag, args, abstractE rhs) 250 | 251 | renameCase env ns e alts = (ns2, ECase e' alts') 252 | where 253 | (ns1, e') = renameE env ns e 254 | (ns2, alts') = mapAccumL (renameAlter env) ns1 alts 255 | 256 | renameAlter :: Assoc Name Name -> NameSupply -> CoreAlter -> (NameSupply, CoreAlter) 257 | renameAlter env ns (tag, args, rhs) = (ns2, (tag, args', rhs')) 258 | where 259 | (ns1, args', env') = newNames ns args 260 | (ns2, rhs') = renameE (env' ++ env) ns1 rhs 261 | 262 | #if __CLH_EXERCISE_6__ >= 5 263 | collectScs = concatMap collectOneSc 264 | where 265 | collectOneSc (scName, args, ELet isRec [(name1, ELam args' body)] (EVar name2)) 266 | | not isRec && name1 == name2 267 | = (scName, args ++ args', body') : scs 268 | where 269 | (scs, body') = collectScsE body 270 | collectOneSc (scName, args, rhs) 271 | = (scName, args, rhs') : scs 272 | where 273 | (scs, rhs') = collectScsE rhs 274 | 275 | #if __CLH_EXERCISE_6__ >= 6 276 | collectScsE (ENum n) = ([], ENum n) 277 | collectScsE (EVar v) = ([], EVar v) 278 | collectScsE (EAp e1 e2) = (scs1 ++ scs2, EAp e1' e2') 279 | where 280 | (scs1, e1') = collectScsE e1 281 | (scs2, e2') = collectScsE e2 282 | collectScsE (ELam args body) = second (ELam args) (collectScsE body) 283 | collectScsE (ELet isRec defns body) 284 | = (rhssScs ++ bodyScs ++ localScs, mkELet isRec nonScs' body') 285 | where 286 | (rhssScs, defns') = mapAccumL collectScsD [] defns 287 | 288 | scs' = filter (isELam . snd) defns' 289 | nonScs' = filter (not . isELam . snd) defns' 290 | localScs 291 | = [ (name, args, body) 292 | | (name, ELam args body) <- scs' 293 | ] 294 | 295 | (bodyScs, body') = collectScsE body 296 | 297 | collectScsD scs (name, ELet isRec [(name1, ELam rhsArgs rhsBody)] (EVar name2)) 298 | | not isRec && name1 == name2 299 | = ((scs ++) *** (,) name . ELam rhsArgs) (collectScsE rhsBody) 300 | collectScsD scs (name, rhs) = ((scs ++) *** (,) name) (collectScsE rhs) 301 | collectScsE (EConstr t a) = ([], EConstr t a) 302 | collectScsE (ECase e alts) 303 | = (scsE ++ scsAlts, ECase e' alts') 304 | where 305 | (scsE, e') = collectScsE e 306 | (scsAlts, alts') = mapAccumL collectScsAlt [] alts 307 | 308 | collectScsAlt scs (tag, args, rhs) 309 | = ((scs ++) *** (,,) tag args) (collectScsE rhs) 310 | 311 | #if __CLH_EXERCISE_6__ >= 7 312 | abstractJ :: AnnProgram Name (Set Name) -> CoreProgram 313 | 314 | lambdaRunJ = putStrLn . runJ 315 | 316 | lambdaLiftJ :: CoreProgram -> CoreProgram 317 | lambdaLiftJ = collectScs . abstractJ . freeVars . rename 318 | 319 | runJ = prettyPrint . lambdaLiftJ . parse 320 | 321 | abstractJE :: Assoc Name [Name] -> AnnExpr Name (Set Name) -> CoreExpr 322 | 323 | abstractJ program 324 | = [ (name, args, abstractJE [] rhs) 325 | | (name, args, rhs) <- program 326 | ] 327 | 328 | #if __CLH_EXERCISE_6__ < 8 329 | abstractJE env (_, ANum n) = ENum n 330 | abstractJE env (_, AConstr t a) = EConstr t a 331 | abstractJE env (_, AAp e1 e2) = EAp (abstractJE env e1) (abstractJE env e2) 332 | abstractJE env (_, AVar g) = foldl EAp (EVar g) (map EVar (aLookup env g [])) 333 | abstractJE env (free, ALam args body) 334 | = foldl EAp sc (map EVar fvList) 335 | where 336 | fvList = actualFreeList env free 337 | sc = ELet nonRecursive [("sc", scRhs)] (EVar "sc") 338 | scRhs = ELam (fvList ++ args) (abstractJE env body) 339 | abstractJE env (_, ALet isRec defns body) = ELet isRec (funDefns' ++ varDefns') body' 340 | where 341 | (funDefns, varDefns) = partition (isALam . snd) defns 342 | 343 | funNames = bindersOf funDefns 344 | freeInFuns = setSubtraction (setUnionList (map (freeVarsOf . snd) funDefns)) (setFromList funNames) 345 | varsToAbstract = actualFreeList env freeInFuns 346 | 347 | bodyEnv = map (flip (,) varsToAbstract) funNames ++ env 348 | rhsEnv 349 | | isRec = bodyEnv 350 | | otherwise = env 351 | 352 | funDefns' 353 | = [ (name, ELam (varsToAbstract ++ args) (abstractJE rhsEnv body)) 354 | | (name, (_, ALam args body)) <- funDefns 355 | ] 356 | varDefns' = map (second (abstractJE rhsEnv)) varDefns 357 | body' = abstractJE bodyEnv body 358 | abstractJE env (_, ACase e alts) = ECase e' alts' 359 | where 360 | e' = abstractJE env e 361 | alts' 362 | = [ (altTag, altArgs, abstractJE env altBody) 363 | | (altTag, altArgs, altBody) <- alts 364 | ] 365 | #endif 366 | 367 | actualFreeList :: Assoc Name [Name] -> Set Name -> [Name] 368 | actualFreeList env free 369 | = setToList (setUnionList [ setFromList (aLookup env name [name]) 370 | | name <- setToList free 371 | ]) 372 | 373 | isALam :: AnnExpr a b -> Bool 374 | isALam (_, ALam _ _) = True 375 | isALam _ = False 376 | 377 | #if __CLH_EXERCISE_6__ >= 8 378 | abstractJE env (_, ANum n) = ENum n 379 | abstractJE env (_, AConstr t a) = EConstr t a 380 | abstractJE env (_, AAp e1 e2) = EAp (abstractJE env e1) (abstractJE env e2) 381 | abstractJE env (_, AVar g) = foldl EAp (EVar g) (map EVar (aLookup env g [])) 382 | abstractJE env (free, ALam args body) 383 | = foldl EAp sc (map EVar fvList) 384 | where 385 | fvList = actualFreeList env free 386 | sc = ELet nonRecursive [("sc", scRhs)] (EVar "sc") 387 | scRhs = ELam (fvList ++ args) (abstractJE env body) 388 | abstractJE env (_, ALet isRec defns body) = ELet isRec (funDefns' ++ varDefns') body' 389 | where 390 | (funDefns, varDefns) = partition (isALam . snd) defns 391 | 392 | funNames = bindersOf funDefns 393 | freeInFuns = setSubtraction (setUnionList (map (freeVarsOf . snd) funDefns)) (setFromList funNames) 394 | varsToAbstract = actualFreeList env freeInFuns 395 | freesInFuns = actualFreeListsOfBindings env (map (second freeVarsOf) funDefns) 396 | 397 | bodyEnv 398 | | isRec = map (second setToList) freesInFuns ++ env 399 | | otherwise = map (flip (,) varsToAbstract) funNames ++ env 400 | rhsEnv 401 | | isRec = bodyEnv 402 | | otherwise = env 403 | 404 | funDefns' 405 | | isRec 406 | = [ (name, ELam (aLookup freesInFuns name setEmpty ++ args) (abstractJE rhsEnv body)) 407 | | (name, (_, ALam args body)) <- funDefns 408 | ] 409 | | otherwise 410 | = [ (name, ELam (varsToAbstract ++ args) (abstractJE rhsEnv body)) 411 | | (name, (_, ALam args body)) <- funDefns 412 | ] 413 | varDefns' = map (second (abstractJE rhsEnv)) varDefns 414 | body' = abstractJE bodyEnv body 415 | abstractJE env (_, ACase e alts) = ECase e' alts' 416 | where 417 | e' = abstractJE env e 418 | alts' 419 | = [ (altTag, altArgs, abstractJE env altBody) 420 | | (altTag, altArgs, altBody) <- alts 421 | ] 422 | 423 | actualFreeListsOfBindings :: Assoc Name [Name] -> Assoc Name (Set Name) -> Assoc Name (Set Name) 424 | actualFreeListsOfBindings env bs 425 | | canImprove = actualFreeListsOfBindings env bs' 426 | | otherwise = map (second (flip setSubtraction (setFromList funNames))) bs 427 | where 428 | funNames = bindersOf bs 429 | 430 | canImprove = any (not . setIsEmpty . uncurry setSubtraction . (snd *** snd)) (zip bs bs') 431 | bs' = improveFreeListsOfBindings env bs 432 | 433 | improveFreeListsOfBindings :: Assoc Name [Name] -> Assoc Name (Set Name) -> Assoc Name (Set Name) 434 | improveFreeListsOfBindings env bs = map (second (actualFreeList env')) bs 435 | where 436 | env' = map (second setToList) bs ++ env 437 | 438 | #if __CLH_EXERCISE_6__ >= 9 439 | lambdaRunF = putStrLn . runF 440 | 441 | separateLams :: CoreProgram -> CoreProgram 442 | 443 | type Level = Int 444 | 445 | addLevels :: CoreProgram -> AnnProgram (Name, Level) Level 446 | 447 | identifyMFEs :: AnnProgram (Name, Level) Level -> Program (Name, Level) 448 | 449 | float :: Program (Name, Level) -> CoreProgram 450 | 451 | fullyLazyLift :: CoreProgram -> CoreProgram 452 | fullyLazyLift = float . renameL . identifyMFEs . addLevels . separateLams 453 | 454 | runF :: String -> String 455 | runF = prettyPrint . lambdaLift . fullyLazyLift . parse 456 | 457 | separateLamsE :: CoreExpr -> CoreExpr 458 | 459 | separateLams program 460 | = [ (name, [], mkSepLams args (separateLamsE rhs)) 461 | | (name, args, rhs) <- program 462 | ] 463 | 464 | separateLamsE e@(ENum _) = e 465 | separateLamsE e@(EVar _) = e 466 | separateLamsE (EAp e1 e2) = EAp (separateLamsE e1) (separateLamsE e2) 467 | separateLamsE (ELam args body) = mkSepLams args (separateLamsE body) 468 | separateLamsE (ELet isRec defns body) = ELet isRec defns' body' 469 | where 470 | defns' = map (second separateLamsE) defns 471 | body' = separateLamsE body 472 | separateLamsE e@(EConstr _ _) = e 473 | separateLamsE (ECase e alts) = ECase e' alts' 474 | where 475 | e' = separateLamsE e 476 | alts' 477 | = [ (name, args, separateLamsE rhs) 478 | | (name, args, rhs) <- alts 479 | ] 480 | 481 | mkSepLams :: [Name] -> CoreExpr -> CoreExpr 482 | mkSepLams = flip (foldr mkSepLam) 483 | where 484 | mkSepLam arg body = ELam [arg] body 485 | 486 | freeToLevel :: AnnProgram Name (Set Name) -> AnnProgram (Name, Level) Level 487 | 488 | addLevels = freeToLevel . freeVars 489 | 490 | freeToLevelSc :: AnnScDefn Name (Set Name) -> AnnScDefn (Name, Level) Level 491 | freeToLevelE :: Level -> Assoc Name Level -> AnnExpr Name (Set Name) -> AnnExpr (Name, Level) Level 492 | 493 | freeToLevel = map freeToLevelSc 494 | 495 | freeToLevelSc (scName, [], rhs) = (scName, [], freeToLevelE 0 [] rhs) 496 | 497 | freeToLevelE _ _ (_, ANum n) = (0, ANum n) 498 | freeToLevelE _ env (_, AVar v) = (aLookup env v 0, AVar v) 499 | freeToLevelE level env (_, AAp e1 e2) = (max (levelOf e1') (levelOf e2'), AAp e1' e2') 500 | where 501 | e1' = freeToLevelE level env e1 502 | e2' = freeToLevelE level env e2 503 | freeToLevelE level env (free, ALam args body) = (freeSetToLevel env free, ALam args' body') 504 | where 505 | args' = map (flip (,) (level + 1)) args 506 | body' = freeToLevelE (level + 1) (args' ++ env) body 507 | freeToLevelE level env (_, ALet isRec defns body) = (levelOf body', ALet isRec defns' body') 508 | where 509 | binders = bindersOf defns 510 | rhss = rhssOf defns 511 | 512 | binder' = map (flip (,) maxRhsLevel) binders 513 | rhss' = map (freeToLevelE level rhsEnv) rhss 514 | defns' = zip binder' rhss' 515 | body' = freeToLevelE level bodyEnv body 516 | 517 | freeInRhss = setUnionList (map fst rhss) 518 | maxRhsLevel = freeSetToLevel levelRhsEnv freeInRhss 519 | 520 | bodyEnv = binder' ++ env 521 | rhsEnv 522 | | isRec = bodyEnv 523 | | otherwise = env 524 | levelRhsEnv 525 | | isRec = map (flip (,) 0) binders ++ env 526 | | otherwise = env 527 | freeToLevelE level env (free, ACase e alts) = freeToLevelCase level env free e alts 528 | 529 | freeToLevelCase :: Level -> Assoc Name Level -> Set Name -> AnnExpr Name (Set Name) -> [AnnAlter Name (Set Name)] -> AnnExpr (Name, Level) Level 530 | #if __CLH_EXERCISE_6__ < 11 531 | freeToLevelCase level env free e alts = error "freeToLevelCase: not yet written" 532 | #endif 533 | 534 | levelOf :: AnnExpr (Name, Level) Level -> Level 535 | levelOf (l, _) = l 536 | 537 | freeSetToLevel :: Assoc Name Level -> Set Name -> Level 538 | freeSetToLevel env = foldl max 0 . map (flip (aLookup env) 0) . setToList 539 | 540 | identifyMFEsE :: Level -> AnnExpr (Name, Level) Level -> Expr (Name, Level) 541 | 542 | identifyMFEs program 543 | = [ (scName, [], identifyMFEsE 0 rhs) 544 | | (scName, [], rhs) <- program 545 | ] 546 | 547 | notMFECandidate :: AnnExpr' (Name, Level) Level -> Bool 548 | notMFECandidate (ANum _) = True 549 | notMFECandidate (AVar _) = True 550 | notMFECandidate (AConstr _ _) = True 551 | notMFECandidate _ = False 552 | 553 | identifyMFEsE' :: Level -> AnnExpr' (Name, Level) Level -> Expr (Name, Level) 554 | 555 | identifyMFEsE ctx (level, e) 556 | | level == ctx || notMFECandidate e = e' 557 | | otherwise = transformMFE level e' 558 | where 559 | e' = identifyMFEsE' level e 560 | 561 | transformMFE :: Level -> Expr (Name, Level) -> Expr (Name, Level) 562 | transformMFE level e = ELet nonRecursive [(("v", level), e)] (EVar "v") 563 | 564 | identifyMFEsE' _ (ANum n) = ENum n 565 | identifyMFEsE' _ (AVar v) = EVar v 566 | identifyMFEsE' level (AAp e1 e2) = EAp (identifyMFEsE level e1) (identifyMFEsE level e2) 567 | identifyMFEsE' _ (ALam args body) = ELam args (identifyMFEsE (snd (head args)) body) 568 | identifyMFEsE' level (ALet isRec defns body) = ELet isRec defns' body' 569 | where 570 | body' = identifyMFEsE level body 571 | defns' 572 | = [ (binding, identifyMFEsE (snd binding) rhs) 573 | | (binding, rhs) <- defns 574 | ] 575 | identifyMFEsE' _ (AConstr t a) = EConstr t a 576 | identifyMFEsE' level (ACase e alts) = identifyMFEsCase level e alts 577 | 578 | identifyMFEsCase :: Level -> AnnExpr (Name, Level) Level -> [AnnAlter (Name, Level) Level] -> Expr (Name, Level) 579 | #if __CLH_EXERCISE_6__ < 11 580 | identifyMFEsCase level e alts = error "identifyMFEsCase: not yet written" 581 | #endif 582 | 583 | renameGen :: (NameSupply -> [a] -> (NameSupply, [a], Assoc Name Name)) -> Program a -> Program a 584 | 585 | rename = renameGen newNames 586 | 587 | #if __CLH_EXERCISE_6__ < 10 588 | renameL :: Program (Name, Level) -> Program (Name, Level) 589 | #endif 590 | renameL = renameGen newNamesL 591 | 592 | #if __CLH_EXERCISE_6__ < 10 593 | newNamesL :: NameSupply -> [(Name, Level)] -> (NameSupply, [(Name, Level)], Assoc Name Name) 594 | #endif 595 | newNamesL ns binders 596 | = (ns', binders', env) 597 | where 598 | names = map fst binders 599 | levels = map snd binders 600 | (ns', names') = getNames ns names 601 | binders' = zip names' levels 602 | env = zip names names' 603 | 604 | renameGenE :: (NameSupply -> [a] -> (NameSupply, [a], Assoc Name Name)) -> Assoc Name Name -> NameSupply -> Expr a -> (NameSupply, Expr a) 605 | 606 | renameGen newBinder = snd . mapAccumL renameSc initialNameSupply 607 | where 608 | renameSc ns (scName, args, rhs) 609 | = (ns2, (scName, args', rhs')) 610 | where 611 | (ns1, args', env) = newBinder ns args 612 | (ns2, rhs') = renameGenE newBinder env ns1 rhs 613 | 614 | renameGenE newBinder _ ns (ENum n) = (ns, ENum n) 615 | renameGenE newBinder env ns (EVar v) = (ns, EVar (aLookup env v v)) 616 | renameGenE newBinder env ns (EAp e1 e2) 617 | = (ns2, EAp e1' e2') 618 | where 619 | (ns1, e1') = renameGenE newBinder env ns e1 620 | (ns2, e2') = renameGenE newBinder env ns1 e2 621 | renameGenE newBinder env ns (ELam args body) 622 | = (ns2, ELam args' body') 623 | where 624 | (ns1, args', env') = newBinder ns args 625 | (ns2, body') = renameGenE newBinder (env' ++ env) ns1 body 626 | renameGenE newBinder env ns (ELet isRec defns body) 627 | = (ns3, ELet isRec (zip binders' rhss') body') 628 | where 629 | (ns1, body') = renameGenE newBinder bodyEnv ns body 630 | binders = bindersOf defns 631 | (ns2, binders', env') = newBinder ns1 binders 632 | bodyEnv = env' ++ env 633 | (ns3, rhss') = mapAccumL (renameGenE newBinder rhsEnv) ns2 (rhssOf defns) 634 | rhsEnv 635 | | isRec = bodyEnv 636 | | otherwise = env 637 | renameGenE newBinder env ns (EConstr t a) = (ns, EConstr t a) 638 | renameGenE newBinder env ns (ECase e alts) = renameGenCase newBinder env ns e alts 639 | 640 | renameGenCase :: (NameSupply -> [a] -> (NameSupply, [a], Assoc Name Name)) -> Assoc Name Name -> NameSupply -> Expr a -> [Alter a] -> (NameSupply, Expr a) 641 | renameGenCase newBinder env ns e alts = (ns2, ECase e' alts') 642 | where 643 | (ns1, e') = renameGenE newBinder env ns e 644 | (ns2, alts') = mapAccumL (renameGenAlter newBinder env) ns1 alts 645 | 646 | renameGenAlter :: (NameSupply -> [a] -> (NameSupply, [a], Assoc Name Name)) -> Assoc Name Name -> NameSupply -> Alter a -> (NameSupply, Alter a) 647 | renameGenAlter newBinder env ns (tag, args, rhs) = (ns2, (tag, args', rhs')) 648 | where 649 | (ns1, args', env') = newBinder ns args 650 | (ns2, rhs') = renameGenE newBinder (env' ++ env) ns1 rhs 651 | 652 | #if __CLH_EXERCISE_6__ >= 10 653 | renameL :: Program (Name, a) -> Program (Name, a) 654 | newNamesL :: NameSupply -> [(Name, a)] -> (NameSupply, [(Name, a)], Assoc Name Name) 655 | #if __CLH_EXERCISE_6__ >= 11 656 | floatSc :: ScDefn (Name, Level) -> [CoreScDefn] 657 | 658 | float = concat . map floatSc 659 | 660 | floatE :: Expr (Name, Level) -> (FloatedDefns, Expr Name) 661 | 662 | floatSc (name, [], rhs) 663 | = [(name, [], rhs')] ++ concat (map toScs fds) 664 | where 665 | (fds, rhs') = floatE rhs 666 | toScs (level, isRec, defns) = map makeSc defns 667 | makeSc (name, rhs) = (name, [], rhs) 668 | 669 | type FloatedDefns = [(Level, IsRec, [(Name, Expr Name)])] 670 | 671 | #if __CLH_EXERCISE_6__ < 12 672 | floatE (ENum n) = ([], ENum n) 673 | floatE (EVar v) = ([], EVar v) 674 | floatE (EAp e1 e2) = (fd1 ++ fd2, EAp e1' e2') 675 | where 676 | (fd1, e1') = floatE e1 677 | (fd2, e2') = floatE e2 678 | floatE (ELam args body) = (fdOuter, ELam args' (install fdThisLevel body')) 679 | where 680 | args' = map fst args 681 | (_, thisLevel) = head args 682 | (fdBody, body') = floatE body 683 | (fdOuter, fdThisLevel) = partitionFloats thisLevel fdBody 684 | floatE (ELet isRec defns body) = (rhsd ++ [thisGroup] ++ bodyd, body') 685 | where 686 | (bodyd, body') = floatE body 687 | (rhsd, defns') = mapAccumL floatDefn [] defns 688 | thisGroup = (snd . head . bindersOf $ defns, isRec, defns') 689 | floatE (EConstr t a) = ([], EConstr t a) 690 | floatE (ECase e alts) = floatCase e alts 691 | #endif 692 | 693 | floatCase :: Expr (Name, Level) -> [Alter (Name, Level)] -> (FloatedDefns, Expr Name) 694 | #if __CLH_EXERCISE_6__ < 11 695 | floatCase e alts = error "floatCase not yet written" 696 | #endif 697 | 698 | floatDefn :: FloatedDefns -> ((Name, Level), Expr (Name, Level)) -> (FloatedDefns, (Name, Expr Name)) 699 | floatDefn ds ((name, level), rhs) 700 | = (rhsd ++ ds, (name, rhs')) 701 | where 702 | (rhsd, rhs') = floatE rhs 703 | 704 | install :: FloatedDefns -> Expr Name -> Expr Name 705 | install defnGroups e 706 | = foldr installGroup e defnGroups 707 | where 708 | installGroup (level, isRec, defns) e = ELet isRec defns e 709 | 710 | partitionFloats :: Level -> FloatedDefns -> (FloatedDefns, FloatedDefns) 711 | partitionFloats thisLevel fds = partition isOuterLevel fds 712 | where 713 | isOuterLevel (level, _, _) = level < thisLevel 714 | 715 | #if __CLH_EXERCISE_6__ >= 11 716 | freeToLevelCase level env free e alts = (freeSetToLevel env free, ACase e' alts') 717 | where 718 | e' = freeToLevelE level env e 719 | alts' = map freeToLevelAlt alts 720 | 721 | freeToLevelAlt (tag, args, rhs) 722 | = (tag, args', freeToLevelE (level + 1) env' rhs) 723 | where 724 | env' = args' ++ env 725 | args' = map (flip (,) (level + 1)) args 726 | 727 | identifyMFEsCase level e alts = ECase (identifyMFEsE level e) (map identifyMFEsAlt alts) 728 | where 729 | identifyMFEsAlt (tag, [], e) = (tag, [], identifyMFEsE level e) 730 | identifyMFEsAlt (tag, args, e) = (tag, args, identifyMFEsE argLevel e) 731 | where 732 | (_, argLevel) = head args 733 | 734 | floatCase e alts = (eds ++ altds, ECase e' alts') 735 | where 736 | (eds, e') = floatE e 737 | (altds, alts') = first concat . unzip . map floatAlter $ alts 738 | 739 | floatAlter (tag, [], rhs) = second ((,,) tag []) (floatE rhs) 740 | floatAlter (tag, args, rhs) = (fdOuter, (tag, args', install fdThisLevel rhs')) 741 | where 742 | args' = map fst args 743 | (_, thisLevel) = head args 744 | (fdRhs, rhs') = floatE rhs 745 | (fdOuter, fdThisLevel) = partitionFloats thisLevel fdRhs 746 | 747 | #if __CLH_EXERCISE_6__ >= 12 748 | floatE (ENum n) = ([], ENum n) 749 | floatE (EVar v) = ([], EVar v) 750 | floatE (EAp e1 e2) = (fd1 ++ fd2, EAp e1' e2') 751 | where 752 | (fd1, e1') = floatE e1 753 | (fd2, e2') = floatE e2 754 | floatE (ELam args body) = (fdOuter, mkELam args' (install fdThisLevel body')) 755 | where 756 | args' = map fst args 757 | (_, thisLevel) = head args 758 | (fdBody, body') = floatE body 759 | (fdOuter, fdThisLevel) = partitionFloats thisLevel fdBody 760 | floatE (ELet isRec defns body) = (rhsd ++ [thisGroup] ++ bodyd, body') 761 | where 762 | (bodyd, body') = floatE body 763 | (rhsd, defns') = mapAccumL floatDefn [] defns 764 | thisGroup = (snd . head . bindersOf $ defns, isRec, defns') 765 | floatE (EConstr t a) = ([], EConstr t a) 766 | floatE (ECase e alts) = floatCase e alts 767 | 768 | mkELam :: [Name] -> CoreExpr -> CoreExpr 769 | mkELam args (ELam args' body) = mkELam (args ++ args') body 770 | mkELam args body = ELam args body 771 | 772 | #if __CLH_EXERCISE_6__ >= 14 773 | depthFirstSearch :: Ord a => (a -> [a]) -> (Set a, [a]) -> [a] -> (Set a, [a]) 774 | depthFirstSearch = foldl . search 775 | where 776 | search relation state@(visited, sequence) vertex 777 | | setElementOf vertex visited = state 778 | | otherwise = (visited', vertex : sequence') 779 | where 780 | (visited', sequence') = depthFirstSearch relation state' (relation vertex) 781 | state' = (setUnion visited (setSingleton vertex), sequence) 782 | 783 | #if __CLH_EXERCISE_6__ >= 15 784 | spanningSearch :: Ord a => (a -> [a]) -> (Set a, [Set a]) -> [a] -> (Set a, [Set a]) 785 | spanningSearch = foldl . search 786 | where 787 | search relation state@(visited, setSequence) vertex 788 | | setElementOf vertex visited = state 789 | | otherwise = (visited', setFromList (vertex : sequence) : setSequence) 790 | where 791 | (visited', sequence) = depthFirstSearch relation state' (relation vertex) 792 | state' = (setUnion visited (setSingleton vertex), []) 793 | 794 | scc :: (Show a, Ord a) => (a -> [a]) -> (a -> [a]) -> [a] -> [Set a] 795 | scc ins outs x 796 | = snd . spanningSearch ins (setEmpty, []) . snd . depthFirstSearch outs (setEmpty, []) $ x 797 | 798 | #if __CLH_EXERCISE_6__ >= 16 799 | lambdaRunD = putStrLn . runD 800 | 801 | dependency :: CoreProgram -> CoreProgram 802 | dependency = depends . freeVars 803 | 804 | runD = prettyPrint . dependency . parse 805 | 806 | depends :: AnnProgram Name (Set Name) -> CoreProgram 807 | depends program 808 | = [ (scName, args, dependsE rhs) 809 | | (scName, args, rhs) <- program 810 | ] 811 | 812 | dependsE :: AnnExpr Name (Set Name) -> CoreExpr 813 | dependsE (_, ANum n) = ENum n 814 | dependsE (_, AVar v) = EVar v 815 | dependsE (_, AAp e1 e2) = EAp (dependsE e1) (dependsE e2) 816 | dependsE (_, ALam args body) = ELam args (dependsE body) 817 | dependsE (free, ALet isRec defns body) 818 | = foldr (mkDependLet isRec) (dependsE body) defnGroups 819 | where 820 | binders = bindersOf defns 821 | binderSet = setFromList binders 822 | 823 | edges 824 | = [ (start, end) 825 | | (start, (free, e)) <- defns 826 | , end <- setToList (setIntersection free binderSet) 827 | ] 828 | 829 | ins v = map fst . filter ((v ==) . snd) $ edges 830 | outs v = map snd . filter ((v ==) . fst) $ edges 831 | 832 | components 833 | | isRec = map setToList (scc ins outs binders) 834 | | otherwise = map setSingleton binders 835 | 836 | defnGroups = map (map (id &&& \n -> aLookup defns n (error "defnGroups"))) components 837 | dependsE (_, AConstr t a) = EConstr t a 838 | dependsE (_, ACase e alts) = ECase (dependsE e) [ (tag, args, dependsE rhs) | (tag, args, rhs) <- alts ] 839 | 840 | mkDependLet :: IsRec -> Assoc Name (AnnExpr Name (Set Name)) -> CoreExpr -> CoreExpr 841 | #if __CLH_EXERCISE_6__ < 16 842 | mkDependLet isRec defns body = ELet isRec (map (second dependsE) defns) body 843 | #endif 844 | 845 | mkDependLet isRec defns body = ELet isReallyRec (map (second dependsE) defns) body 846 | where 847 | binderSet = setFromList (bindersOf defns) 848 | isReallyRec 849 | | isRec = not . all (setIsEmpty . (setIntersection binderSet)) . map (freeVarsOf . snd) $ defns 850 | | otherwise = nonRecursive 851 | #endif 852 | #endif 853 | #endif 854 | #endif 855 | #endif 856 | #else 857 | float = undefined 858 | #endif 859 | #endif 860 | #endif 861 | #endif 862 | #endif 863 | #endif 864 | #endif 865 | #endif 866 | #endif 867 | -------------------------------------------------------------------------------- /src/Language/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Language.Parser 3 | ( clex 4 | , syntax 5 | , parse 6 | ) 7 | where 8 | 9 | import Data.Char 10 | import Language.Types 11 | import Util 12 | 13 | #if __CLH_EXERCISE_1__ < 11 14 | clex :: String -> [Token] 15 | #endif 16 | syntax :: [Token] -> CoreProgram 17 | 18 | parse :: String -> CoreProgram 19 | #if __CLH_EXERCISE_1__ < 11 20 | parse = syntax . clex 21 | 22 | type Token = String 23 | 24 | clex (c : cs) | isSpace c = clex cs 25 | clex (c : cs) | isDigit c = numToken : clex restCs 26 | where 27 | numToken = c : takeWhile isDigit cs 28 | restCs = dropWhile isDigit cs 29 | clex (c : cs) | isAlpha c = varToken : clex restCs 30 | where 31 | varToken = c : takeWhile isIdChar cs 32 | restCs = dropWhile isIdChar cs 33 | #if __CLH_EXERCISE_1__ >= 9 34 | clex ('|' : '|' : cs) = clex restCs 35 | where 36 | restCs = dropWhile (`notElem` "\r\n") cs 37 | #endif 38 | #if __CLH_EXERCISE_1__ >= 10 39 | clex (c0 : c1 : cs) | op `elem` twoCharOps = op : clex cs 40 | where 41 | op = [c0, c1] 42 | #endif 43 | clex (c : cs) = [c] : clex cs 44 | clex [] = [] 45 | #endif 46 | 47 | isIdChar c = isAlpha c || isDigit c || c == '_' 48 | 49 | -- | 50 | -- Following 'twoCharOps' is a part of exercise 1.10 51 | twoCharOps :: [String] 52 | twoCharOps = ["==", "~=", ">=", "<=", "->"] 53 | 54 | #if __CLH_EXERCISE_1__ >= 11 55 | parse = syntax . clex 0 56 | 57 | type Token = (Int, String) 58 | 59 | clex :: Int -> String -> [Token] 60 | clex l ('\r' : '\n' : cs) = clex (l + 1) cs 61 | clex l ('\n' : '\r' : cs) = clex (l + 1) cs 62 | clex l ('\n' : cs) = clex (l + 1) cs 63 | clex l (c : cs) | isSpace c = clex l cs 64 | clex l (c : cs) | isDigit c = (l, numTokVal) : clex l restCs 65 | where 66 | numTokVal = c : takeWhile isDigit cs 67 | restCs = dropWhile isDigit cs 68 | clex l (c : cs) | isAlpha c = (l, varTokVal) : clex l restCs 69 | where 70 | varTokVal = c : takeWhile isIdChar cs 71 | restCs = dropWhile isIdChar cs 72 | clex l ('|' : '|' : cs) = clex l restCs 73 | where 74 | restCs = dropWhile (`notElem` "\r\n") cs 75 | clex l (c0 : c1 : cs) | opTokVal `elem` twoCharOps = (l, opTokVal) : clex l cs 76 | where 77 | opTokVal = [c0, c1] 78 | clex l (c : cs) = (l, [c]) : clex l cs 79 | clex l [] = [] 80 | 81 | type Parser a = [Token] -> Assoc a [Token] 82 | 83 | pLit :: String -> Parser String 84 | #if __CLH_EXERCISE_1__ < 16 85 | pLit s ((_, tokVal) : toks) 86 | | s == tokVal = [(s, toks)] 87 | | otherwise = [] 88 | pLit _ [] = [] 89 | #endif 90 | 91 | pVar :: Parser String 92 | #if __CLH_EXERCISE_1__ < 16 93 | pVar ((_, c : cs) : toks) 94 | | isAlpha c = [(c : cs, toks)] 95 | | otherwise = [] 96 | pVar ((_, []) : _) = [] 97 | pVar [] = [] 98 | #endif 99 | 100 | pAlt :: Parser a -> Parser a -> Parser a 101 | pAlt p1 p2 toks = p1 toks ++ p2 toks 102 | 103 | pThen :: (a -> b -> c) -> Parser a -> Parser b -> Parser c 104 | pThen combine p1 p2 toks 105 | = [ (combine v1 v2, toks2) 106 | | (v1, toks1) <- p1 toks 107 | , (v2, toks2) <- p2 toks1 108 | ] 109 | 110 | #if __CLH_EXERCISE_1__ >= 12 111 | pThen3 :: (a -> b -> c -> d) -> Parser a -> Parser b -> Parser c -> Parser d 112 | pThen3 combine p1 p2 p3 toks 113 | = [ (combine v1 v2 v3, toks3) 114 | | (v1, toks1) <- p1 toks 115 | , (v2, toks2) <- p2 toks1 116 | , (v3, toks3) <- p3 toks2 117 | ] 118 | 119 | pThen4 :: (a -> b -> c -> d -> e) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e 120 | pThen4 combine p1 p2 p3 p4 toks 121 | = [ (combine v1 v2 v3 v4, toks4) 122 | | (v1, toks1) <- p1 toks 123 | , (v2, toks2) <- p2 toks1 124 | , (v3, toks3) <- p3 toks2 125 | , (v4, toks4) <- p4 toks3 126 | ] 127 | 128 | #if __CLH_EXERCISE_1__ >= 13 129 | pZeroOrMore :: Parser a -> Parser [a] 130 | -- | 131 | -- This one shows bad performance 132 | -- since it always produces empty result even when 133 | -- first parser succeeded. 134 | #if __CLH_EXERCISE_1__ < 19 135 | pZeroOrMore p = pOneOrMore p `pAlt` pEmpty [] 136 | #endif 137 | 138 | pEmpty :: a -> Parser a 139 | pEmpty v toks = [(v, toks)] 140 | 141 | pOneOrMore :: Parser a -> Parser [a] 142 | pOneOrMore p = pThen (:) p (pZeroOrMore p) 143 | 144 | #if __CLH_EXERCISE_1__ >= 14 145 | pApply :: Parser a -> (a -> b) -> Parser b 146 | pApply p f toks 147 | = [ (f v', toks') 148 | | (v', toks') <- p toks 149 | ] 150 | 151 | #if __CLH_EXERCISE_1__ >= 15 152 | pOneOrMoreWithSep :: Parser a -> Parser b -> Parser [a] 153 | pOneOrMoreWithSep pV pSep 154 | = pThen (:) pV (pZeroOrMore (pThen (const id) pSep pV)) 155 | 156 | #if __CLH_EXERCISE_1__ >= 16 157 | pLit s = pSat (== s) 158 | 159 | pSat :: (String -> Bool) -> Parser String 160 | pSat pred ((_, tokVal) : toks) 161 | | pred tokVal = [(tokVal, toks)] 162 | | otherwise = [] 163 | pSat _ [] = [] 164 | 165 | #if __CLH_EXERCISE_1__ < 17 166 | pVar = pSat isVal 167 | where 168 | isVal (c : _) 169 | | isAlpha c = True 170 | | otherwise = False 171 | isVal [] = False 172 | #endif 173 | 174 | #if __CLH_EXERCISE_1__ >= 17 175 | keywords :: [String] 176 | keywords = ["let", "letrec", "case", "in", "of", "Pack"] 177 | 178 | pVar = pSat isVal 179 | where 180 | isVal cs@(c : _) 181 | | cs `elem` keywords = False 182 | | isAlpha c = True 183 | | otherwise = False 184 | isVal [] = False 185 | 186 | #if __CLH_EXERCISE_1__ >= 18 187 | pNum :: Parser Int 188 | pNum = pSat isNumber `pApply` read 189 | where 190 | isNumber (c : _) 191 | | isDigit c = True 192 | | otherwise = False 193 | isNumber [] = False 194 | 195 | #if __CLH_EXERCISE_1__ >= 19 196 | pIfFail :: Parser a -> Parser a -> Parser a 197 | pIfFail p1 p2 toks = 198 | case p1 toks of 199 | res@(_:_) -> res 200 | [] -> p2 toks 201 | 202 | pZeroOrMore p = pOneOrMore p `pIfFail` pEmpty [] 203 | 204 | syntax = takeFirstParse . pProgram 205 | where 206 | takeFirstParse ((prog, []) : _) = prog 207 | takeFirstParse (_ : others) = takeFirstParse others 208 | takeFirstParse [] = error "Syntax error" 209 | 210 | pProgram :: Parser CoreProgram 211 | pProgram = pOneOrMoreWithSep pSc (pLit ";") 212 | 213 | pSc :: Parser CoreScDefn 214 | pSc = pThen4 mkSc pVar (pZeroOrMore pVar) (pLit "=") pExpr 215 | 216 | mkSc :: Name -> [Name] -> a -> CoreExpr -> CoreScDefn 217 | #if __CLH_EXERCISE_1__ >= 20 218 | mkSc name vars _ expr = (name, vars, expr) 219 | #else 220 | mkSc = undefined 221 | #endif 222 | 223 | pExpr :: Parser CoreExpr 224 | #if __CLH_EXERCISE_1__ >= 21 225 | #if __CLH_EXERCISE_1__ < 23 226 | pExpr 227 | = pLet recursive `pAlt` 228 | pLet nonRecursive `pAlt` 229 | pCase `pAlt` 230 | pLambda `pAlt` 231 | pAExpr 232 | #endif 233 | 234 | pLet :: IsRec -> Parser CoreExpr 235 | pLet isRec = pThen4 (mkLet isRec) (pLit keyword) pDefns (pLit "in") pExpr 236 | where 237 | keyword 238 | | isRec = "letrec" 239 | | otherwise = "let" 240 | mkLet :: IsRec -> a -> Assoc Name CoreExpr -> b -> CoreExpr -> CoreExpr 241 | mkLet isRec _ defns _ = ELet isRec defns 242 | 243 | pDefns :: Parser (Assoc Name CoreExpr) 244 | pDefns = pOneOrMoreWithSep pDefn (pLit ";") 245 | pDefn :: Parser (Name, CoreExpr) 246 | pDefn = pThen3 mkDefn pVar (pLit "=") pExpr 247 | mkDefn :: Name -> a -> CoreExpr -> (Name, CoreExpr) 248 | mkDefn name _ expr = (name, expr) 249 | 250 | pCase :: Parser CoreExpr 251 | pCase = pThen4 mkCase (pLit "case") pExpr (pLit "of") pAlters 252 | mkCase :: a -> CoreExpr -> b -> [CoreAlter] -> CoreExpr 253 | mkCase _ expr _ = ECase expr 254 | pAlters :: Parser [CoreAlter] 255 | pAlters = pOneOrMoreWithSep pAlter (pLit ";") 256 | pAlter :: Parser CoreAlter 257 | pAlter = pThen3 mkAlter pPattern (pLit "->") pExpr 258 | mkAlter :: (Int, [Name]) -> a -> CoreExpr -> CoreAlter 259 | mkAlter (tag, vars) _ expr = (tag, vars, expr) 260 | pPattern :: Parser (Int, [Name]) 261 | pPattern = pThen4 mkPattern (pLit "<") pNum (pLit ">") (pZeroOrMore pVar) 262 | mkPattern :: a -> Int -> b -> [Name] -> (Int, [Name]) 263 | mkPattern _ tag _ vars = (tag, vars) 264 | 265 | pLambda :: Parser CoreExpr 266 | pLambda = pThen4 mkLambda (pLit "\\") (pOneOrMore pVar) (pLit ".") pExpr 267 | mkLambda :: a -> [Name] -> b -> CoreExpr -> CoreExpr 268 | mkLambda _ vars _ = ELam vars 269 | 270 | pAExpr :: Parser CoreExpr 271 | pAExpr 272 | = (pNum `pApply` ENum) `pAlt` 273 | (pVar `pApply` EVar) `pAlt` 274 | pConstr `pAlt` 275 | pThen3 ignoreParen (pLit "(") pExpr (pLit ")") 276 | where 277 | ignoreParen _ expr _ = expr 278 | 279 | pConstr :: Parser CoreExpr 280 | pConstr = pThen4 mkConstr (pLit "Pack") (pLit "{") pNums (pLit "}") 281 | mkConstr :: a -> b -> (Int, Int) -> c -> CoreExpr 282 | mkConstr _ _ (tag, arity) _ = EConstr tag arity 283 | pNums :: Parser (Int, Int) 284 | pNums = pThen3 mkNums pNum (pLit ",") pNum 285 | mkNums :: Int -> a -> Int -> (Int, Int) 286 | mkNums a _ b = (a, b) 287 | #else 288 | pExpr = undefined 289 | #endif 290 | 291 | #if __CLH_EXERCISE_1__ >= 23 292 | #if __CLH_EXERCISE_1__ < 24 293 | pExpr 294 | = (pOneOrMore pAExpr `pApply` mkApChain) `pAlt` 295 | pLet recursive `pAlt` 296 | pLet nonRecursive `pAlt` 297 | pCase `pAlt` 298 | pLambda `pAlt` 299 | pAExpr 300 | #endif 301 | 302 | mkApChain :: [CoreExpr] -> CoreExpr 303 | mkApChain (expr:exprs) = foldl EAp expr exprs 304 | mkApChain [] = error "Compiler Bug mkApChain" 305 | 306 | #if __CLH_EXERCISE_1__ >= 24 307 | data PartialExpr 308 | = NoOp 309 | | FoundOp Name CoreExpr 310 | 311 | pExpr 312 | = pLet recursive `pAlt` 313 | pLet nonRecursive `pAlt` 314 | pCase `pAlt` 315 | pLambda `pAlt` 316 | pExpr1 317 | 318 | pExpr1c :: Parser PartialExpr 319 | pExpr1c 320 | = pThen FoundOp (pLit "|") pExpr1 `pAlt` 321 | pEmpty NoOp 322 | 323 | pExpr1 :: Parser CoreExpr 324 | pExpr1 = pThen assembleOp pExpr2 pExpr1c 325 | 326 | pExpr2c :: Parser PartialExpr 327 | pExpr2c 328 | = pThen FoundOp (pLit "&") pExpr2 `pAlt` 329 | pEmpty NoOp 330 | 331 | pExpr2 :: Parser CoreExpr 332 | pExpr2 = pThen assembleOp pExpr3 pExpr2c 333 | 334 | pExpr3c :: Parser PartialExpr 335 | pExpr3c 336 | = pThen FoundOp pRelOp pExpr3 `pAlt` 337 | pEmpty NoOp 338 | 339 | relOps :: [Name] 340 | relOps = ["<", "<=", "==", "~=", ">=", ">"] 341 | 342 | pRelOp :: Parser Name 343 | pRelOp = pSat (`elem` relOps) 344 | 345 | pExpr3 :: Parser CoreExpr 346 | pExpr3 = pThen assembleOp pExpr4 pExpr3c 347 | 348 | pExpr4c :: Parser PartialExpr 349 | pExpr4c 350 | = pThen FoundOp (pLit "+") pExpr4 `pAlt` 351 | pThen FoundOp (pLit "-") pExpr5 `pAlt` 352 | pEmpty NoOp 353 | 354 | pExpr4 :: Parser CoreExpr 355 | pExpr4 = pThen assembleOp pExpr5 pExpr4c 356 | 357 | pExpr5c :: Parser PartialExpr 358 | pExpr5c 359 | = pThen FoundOp (pLit "*") pExpr5 `pAlt` 360 | pThen FoundOp (pLit "/") pExpr6 `pAlt` 361 | pEmpty NoOp 362 | 363 | pExpr5 :: Parser CoreExpr 364 | pExpr5 = pThen assembleOp pExpr6 pExpr5c 365 | 366 | pExpr6 :: Parser CoreExpr 367 | pExpr6 = pOneOrMore pAExpr `pApply` mkApChain 368 | 369 | assembleOp :: CoreExpr -> PartialExpr -> CoreExpr 370 | assembleOp e1 NoOp = e1 371 | assembleOp e1 (FoundOp op e2) = EAp (EAp (EVar op) e1) e2 372 | #endif 373 | #endif 374 | #endif 375 | #endif 376 | #endif 377 | #endif 378 | #endif 379 | #endif 380 | #endif 381 | #endif 382 | #else 383 | syntax = undefined 384 | #endif 385 | -------------------------------------------------------------------------------- /src/Language/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Language.Prelude where 2 | 3 | import Language.Types 4 | 5 | preludeDefs :: CoreProgram 6 | preludeDefs 7 | = [ ("I", ["x"], EVar "x") 8 | , ("K", ["x", "y"], EVar "x") 9 | , ("K1", ["x", "y"], EVar "y") 10 | , ("S", ["f", "g", "x"], EAp (EAp (EVar "f") (EVar "x")) (EAp (EVar "g") (EVar "x"))) 11 | , ("compose", ["f", "g", "x"], EAp (EVar "f") (EAp (EVar "g") (EVar "x"))) 12 | , ("twice", ["f"], EAp (EAp (EVar "compose") (EVar "f")) (EVar "f")) 13 | ] 14 | -------------------------------------------------------------------------------- /src/Language/PrettyPrinter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Language.PrettyPrinter where 3 | 4 | import Data.ISeq 5 | import Language.Types 6 | import Util 7 | 8 | prettyPrint :: CoreProgram -> String 9 | 10 | -- | 11 | -- Following codes show bad performances, 12 | -- therefore they are impractical. 13 | -- See for data. 14 | #if __CLH_EXERCISE_1__ == 1 15 | prettyPrintExpr :: CoreExpr -> String 16 | prettyPrintExpr (ENum n) = show n 17 | prettyPrintExpr (EVar v) = v 18 | prettyPrintExpr (EAp e1 e2) = prettyPrintExpr e1 ++ " " ++ prettyPrintAExpr e2 19 | 20 | prettyPrintAExpr :: CoreExpr -> String 21 | prettyPrintAExpr e 22 | | isAExpr e = prettyPrintExpr e 23 | | otherwise = "(" ++ prettyPrintExpr e ++ ")" 24 | 25 | -- | 26 | -- Utility for exercise 1.1 27 | makeMultiAp :: Int -> CoreExpr -> CoreExpr -> CoreExpr 28 | makeMultiAp n e1 e2 = foldl EAp e1 (take n e2s) 29 | where 30 | e2s = e2 : e2s 31 | #endif 32 | 33 | #if __CLH_EXERCISE_1__ > 1 34 | #if __CLH_EXERCISE_1__ < 8 35 | prettyPrintExpr :: CoreExpr -> ISeq 36 | #if __CLH_EXERCISE_1__ < 3 37 | prettyPrintExpr (EVar v) = iStr v 38 | prettyPrintExpr (EAp e1 e2) = prettyPrintExpr e1 `iAppend` iStr " " `iAppend` prettyPrintAExpr e2 39 | prettyPrintExpr (ELet isRec defns expr) 40 | = iConcat [ iStr keyword, iNewline 41 | , iStr " ", iIndent (prettyPrintDefinitions defns), iNewline 42 | , iStr "in ", prettyPrintExpr expr 43 | ] 44 | where 45 | keyword 46 | | not isRec = "let" 47 | | otherwise = "letrec" 48 | #endif 49 | 50 | prettyPrintDefinitions :: Assoc Name CoreExpr -> ISeq 51 | prettyPrintDefinitions defns 52 | = iInterleave sep (map prettyPrintDefinition defns) 53 | where 54 | sep = iConcat [ iStr ";", iNewline ] 55 | 56 | prettyPrintDefinition :: (Name, CoreExpr) -> ISeq 57 | prettyPrintDefinition (name, expr) 58 | = iConcat [ iStr name, iStr " = ", iIndent (prettyPrintExpr expr) ] 59 | 60 | -- | 61 | -- Following two patterns of 'prettyPrintExpr', 62 | -- 'prettyPrintAlternatives', 'prettyPrintAlternative', 63 | -- 'prettyPrintVars', 'prettyPrintAExpr', 64 | -- 'prettyPrintProgram' and 'prettyPrintSupercombinatorDefinition' 65 | -- are exercise 1.3 66 | #if __CLH_EXERCISE_1__ >= 3 67 | prettyPrintExpr (EVar v) = iStr v 68 | prettyPrintExpr (EAp e1 e2) = prettyPrintExpr e1 `iAppend` iStr " " `iAppend` prettyPrintAExpr e2 69 | prettyPrintExpr (ELet isRec defns expr) 70 | = iConcat [ iStr keyword, iNewline 71 | , iStr " ", iIndent (prettyPrintDefinitions defns), iNewline 72 | , iStr "in ", prettyPrintExpr expr 73 | ] 74 | where 75 | keyword 76 | | not isRec = "let" 77 | | otherwise = "letrec" 78 | prettyPrintExpr (ECase expr alters) 79 | = iConcat [ iStr "case ", iIndent (prettyPrintExpr expr), iStr " of", iNewline 80 | , iStr " ", iIndent (prettyPrintAlternatives alters) 81 | ] 82 | prettyPrintExpr (ELam vars expr) 83 | = iConcat [ iStr "\\ ", prettyPrintVars vars, iStr " .", iNewline 84 | , iStr " ", iIndent (prettyPrintExpr expr) 85 | ] 86 | 87 | prettyPrintAlternatives :: [CoreAlter] -> ISeq 88 | prettyPrintAlternatives alters 89 | = iInterleave sep (map prettyPrintAlternative alters) 90 | where 91 | sep = iConcat [ iStr ";", iNewline ] 92 | 93 | prettyPrintAlternative :: CoreAlter -> ISeq 94 | prettyPrintAlternative (tag, [], expr) 95 | = iConcat [ iStr "<", iStr (show tag), iStr "> -> ", iIndent (prettyPrintExpr expr) ] 96 | prettyPrintAlternative (tag, vars, expr) 97 | = iConcat [ iStr "<", iStr (show tag), iStr "> ", prettyPrintVars vars, iStr " -> ", iIndent (prettyPrintExpr expr) ] 98 | #endif 99 | #endif 100 | 101 | #if __CLH_EXERCISE_1__ >= 3 102 | prettyPrintVars :: [Name] -> ISeq 103 | prettyPrintVars vars 104 | = iInterleave (iStr " ") (map iStr vars) 105 | 106 | #if __CLH_EXERCISE_1__ < 8 107 | prettyPrintAExpr :: CoreExpr -> ISeq 108 | prettyPrintAExpr expr 109 | | isAExpr expr = prettyPrintExpr expr 110 | | otherwise = iConcat [ iStr "(", prettyPrintExpr expr, iStr ")" ] 111 | #endif 112 | 113 | prettyPrintProgram :: CoreProgram -> ISeq 114 | prettyPrintProgram scdefns 115 | = iInterleave sep (map prettyPrintSupercombinatorDefinition scdefns) 116 | where 117 | sep = iConcat [ iStr ";", iNewline ] 118 | 119 | prettyPrintSupercombinatorDefinition :: CoreScDefn -> ISeq 120 | #if __CLH_EXERCISE_1__ < 8 121 | prettyPrintSupercombinatorDefinition (name, [], expr) 122 | = iConcat [ iStr name, iStr " = ", iIndent (prettyPrintExpr expr) ] 123 | prettyPrintSupercombinatorDefinition (name, vars, expr) 124 | = iConcat [ iStr name, iStr " ", prettyPrintVars vars, iStr " = ", iIndent (prettyPrintExpr expr) ] 125 | #endif 126 | 127 | -- | 128 | -- 'prettyPrintExpr' with 'ISep' works much faster than one without it. 129 | -- See for data. 130 | #if __CLH_EXERCISE_1__ == 4 131 | makeMultiAp :: Int -> CoreExpr -> CoreExpr -> CoreExpr 132 | makeMultiAp n e1 e2 = foldl EAp e1 (take n e2s) 133 | where 134 | e2s = e2 : e2s 135 | #endif 136 | 137 | #if __CLH_EXERCISE_1__ >= 8 138 | prettyPrintExpr :: Int -> CoreExpr -> ISeq 139 | prettyPrintExpr _ (ENum n) = iNum n 140 | prettyPrintExpr _ (EVar v) = iStr v 141 | prettyPrintExpr prec (EAp (EAp (EVar "|") e1) e2) 142 | = iPrecParen prec 1 . iConcat $ [ prettyPrintExpr 2 e1, iStr " | ", prettyPrintExpr 1 e2 ] 143 | prettyPrintExpr prec (EAp (EAp (EVar "&") e1) e2) 144 | = iPrecParen prec 2 . iConcat $ [ prettyPrintExpr 3 e1, iStr " & ", prettyPrintExpr 2 e2 ] 145 | prettyPrintExpr prec (EAp (EAp (EVar "==") e1) e2) 146 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExpr 4 e1, iStr " == ", prettyPrintExpr 4 e2 ] 147 | prettyPrintExpr prec (EAp (EAp (EVar "~=") e1) e2) 148 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExpr 4 e1, iStr " ~= ", prettyPrintExpr 4 e2 ] 149 | prettyPrintExpr prec (EAp (EAp (EVar ">") e1) e2) 150 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExpr 4 e1, iStr " > ", prettyPrintExpr 4 e2 ] 151 | prettyPrintExpr prec (EAp (EAp (EVar ">=") e1) e2) 152 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExpr 4 e1, iStr " >= ", prettyPrintExpr 4 e2 ] 153 | prettyPrintExpr prec (EAp (EAp (EVar "<") e1) e2) 154 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExpr 4 e1, iStr " < ", prettyPrintExpr 4 e2 ] 155 | prettyPrintExpr prec (EAp (EAp (EVar "<=") e1) e2) 156 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExpr 4 e1, iStr " <= ", prettyPrintExpr 4 e2 ] 157 | prettyPrintExpr prec (EAp (EAp (EVar "+") e1) e2) 158 | = iPrecParen prec 4 . iConcat $ [ prettyPrintExpr 5 e1, iStr " + ", prettyPrintExpr 4 e2 ] 159 | prettyPrintExpr prec (EAp (EAp (EVar "-") e1) e2) 160 | = iPrecParen prec 4 . iConcat $ [ prettyPrintExpr 5 e1, iStr " - ", prettyPrintExpr 5 e2 ] 161 | prettyPrintExpr prec (EAp (EAp (EVar "*") e1) e2) 162 | = iPrecParen prec 5 . iConcat $ [ prettyPrintExpr 6 e1, iStr " * ", prettyPrintExpr 5 e2 ] 163 | prettyPrintExpr prec (EAp (EAp (EVar "/") e1) e2) 164 | = iPrecParen prec 5 . iConcat $ [ prettyPrintExpr 6 e1, iStr " / ", prettyPrintExpr 6 e2 ] 165 | prettyPrintExpr prec (EAp e1 e2) 166 | = iPrecParen prec 10 . iConcat $ [ prettyPrintExpr 10 e1, iStr " ", prettyPrintExpr 11 e2 ] 167 | prettyPrintExpr _ (ELet isRec defns expr) 168 | = iConcat [ iStr keyword, iNewline 169 | , iStr " ", iIndent (prettyPrintDefinitions defns), iNewline 170 | , iStr "in ", prettyPrintExpr 0 expr 171 | ] 172 | where 173 | keyword 174 | | not isRec = "let" 175 | | otherwise = "letrec" 176 | prettyPrintExpr _ (ECase expr alters) 177 | = iConcat [ iStr "case ", iIndent (prettyPrintExpr 0 expr), iStr " of", iNewline 178 | , iStr " ", iIndent (prettyPrintAlternatives alters) 179 | ] 180 | prettyPrintExpr _ (ELam vars expr) 181 | = iConcat [ iStr "\\ ", prettyPrintVars vars, iStr " .", iNewline 182 | , iStr " ", iIndent (prettyPrintExpr 0 expr) 183 | ] 184 | prettyPrintExpr _ (EConstr t a) 185 | = iConcat [ iStr "Pack{", iNum t, iStr ",", iNum a, iStr "}" ] 186 | 187 | prettyPrintAlternatives :: [CoreAlter] -> ISeq 188 | prettyPrintAlternatives alters 189 | = iInterleave sep (map prettyPrintAlternative alters) 190 | where 191 | sep = iConcat [ iStr ";", iNewline ] 192 | 193 | prettyPrintAlternative :: CoreAlter -> ISeq 194 | prettyPrintAlternative (tag, [], expr) 195 | = iConcat [ iStr "<", iStr (show tag), iStr "> -> ", iIndent (prettyPrintExpr 0 expr) ] 196 | prettyPrintAlternative (tag, vars, expr) 197 | = iConcat [ iStr "<", iStr (show tag), iStr "> ", prettyPrintVars vars, iStr " -> ", iIndent (prettyPrintExpr 0 expr) ] 198 | 199 | prettyPrintDefinitions :: Assoc Name CoreExpr -> ISeq 200 | prettyPrintDefinitions defns 201 | = iInterleave sep (map prettyPrintDefinition defns) 202 | where 203 | sep = iConcat [ iStr ";", iNewline ] 204 | 205 | prettyPrintDefinition :: (Name, CoreExpr) -> ISeq 206 | prettyPrintDefinition (name, expr) 207 | = iConcat [ iStr name, iStr " = ", iIndent (prettyPrintExpr 0 expr) ] 208 | 209 | prettyPrintSupercombinatorDefinition (name, [], expr) 210 | = iConcat [ iStr name, iStr " = ", iIndent (prettyPrintExpr 0 expr) ] 211 | prettyPrintSupercombinatorDefinition (name, vars, expr) 212 | = iConcat [ iStr name, iStr " ", prettyPrintVars vars, iStr " = ", iIndent (prettyPrintExpr 0 expr) ] 213 | 214 | prettyPrint program = iDisplay (prettyPrintProgram program) 215 | 216 | #if __CLH_EXERCISE_6__ >= 1 217 | prettyPrintGen :: (a -> ISeq) -> Program a -> String 218 | prettyPrintGen f program = iDisplay (prettyPrintProgramGen f program) 219 | 220 | prettyPrintProgramGen :: (a -> ISeq) -> Program a -> ISeq 221 | prettyPrintProgramGen f scdefns 222 | = iInterleave sep (map (prettyPrintSupercombinatorDefinitionGen f) scdefns) 223 | where 224 | sep = iConcat [ iStr ";", iNewline ] 225 | 226 | prettyPrintSupercombinatorDefinitionGen :: (a -> ISeq) -> ScDefn a -> ISeq 227 | prettyPrintSupercombinatorDefinitionGen f (name, [], expr) 228 | = iConcat [ iStr name, iStr " = ", iIndent (prettyPrintExprGen f 0 expr) ] 229 | prettyPrintSupercombinatorDefinitionGen f (name, vars, expr) 230 | = iConcat [ iStr name, iStr " ", prettyPrintVarsGen f vars, iStr " = ", iIndent (prettyPrintExprGen f 0 expr) ] 231 | 232 | prettyPrintExprGen :: (a -> ISeq) -> Int -> Expr a -> ISeq 233 | prettyPrintExprGen _ _ (ENum n) = iNum n 234 | prettyPrintExprGen _ _ (EVar v) = iStr v 235 | prettyPrintExprGen f prec (EAp (EAp (EVar "|") e1) e2) 236 | = iPrecParen prec 1 . iConcat $ [ prettyPrintExprGen f 2 e1, iStr " | ", prettyPrintExprGen f 1 e2 ] 237 | prettyPrintExprGen f prec (EAp (EAp (EVar "&") e1) e2) 238 | = iPrecParen prec 2 . iConcat $ [ prettyPrintExprGen f 3 e1, iStr " & ", prettyPrintExprGen f 2 e2 ] 239 | prettyPrintExprGen f prec (EAp (EAp (EVar "==") e1) e2) 240 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExprGen f 4 e1, iStr " == ", prettyPrintExprGen f 4 e2 ] 241 | prettyPrintExprGen f prec (EAp (EAp (EVar "~=") e1) e2) 242 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExprGen f 4 e1, iStr " ~= ", prettyPrintExprGen f 4 e2 ] 243 | prettyPrintExprGen f prec (EAp (EAp (EVar ">") e1) e2) 244 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExprGen f 4 e1, iStr " > ", prettyPrintExprGen f 4 e2 ] 245 | prettyPrintExprGen f prec (EAp (EAp (EVar ">=") e1) e2) 246 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExprGen f 4 e1, iStr " >= ", prettyPrintExprGen f 4 e2 ] 247 | prettyPrintExprGen f prec (EAp (EAp (EVar "<") e1) e2) 248 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExprGen f 4 e1, iStr " < ", prettyPrintExprGen f 4 e2 ] 249 | prettyPrintExprGen f prec (EAp (EAp (EVar "<=") e1) e2) 250 | = iPrecParen prec 3 . iConcat $ [ prettyPrintExprGen f 4 e1, iStr " <= ", prettyPrintExprGen f 4 e2 ] 251 | prettyPrintExprGen f prec (EAp (EAp (EVar "+") e1) e2) 252 | = iPrecParen prec 4 . iConcat $ [ prettyPrintExprGen f 5 e1, iStr " + ", prettyPrintExprGen f 4 e2 ] 253 | prettyPrintExprGen f prec (EAp (EAp (EVar "-") e1) e2) 254 | = iPrecParen prec 4 . iConcat $ [ prettyPrintExprGen f 5 e1, iStr " - ", prettyPrintExprGen f 5 e2 ] 255 | prettyPrintExprGen f prec (EAp (EAp (EVar "*") e1) e2) 256 | = iPrecParen prec 5 . iConcat $ [ prettyPrintExprGen f 6 e1, iStr " * ", prettyPrintExprGen f 5 e2 ] 257 | prettyPrintExprGen f prec (EAp (EAp (EVar "/") e1) e2) 258 | = iPrecParen prec 5 . iConcat $ [ prettyPrintExprGen f 6 e1, iStr " / ", prettyPrintExprGen f 6 e2 ] 259 | prettyPrintExprGen f prec (EAp e1 e2) 260 | = iPrecParen prec 10 . iConcat $ [ prettyPrintExprGen f 10 e1, iStr " ", prettyPrintExprGen f 11 e2 ] 261 | prettyPrintExprGen f _ (ELet isRec defns expr) 262 | = iConcat [ iStr keyword, iNewline 263 | , iStr " ", iIndent (prettyPrintDefinitionsGen f defns), iNewline 264 | , iStr "in ", prettyPrintExprGen f 0 expr 265 | ] 266 | where 267 | keyword 268 | | not isRec = "let" 269 | | otherwise = "letrec" 270 | prettyPrintExprGen f _ (ECase expr alters) 271 | = iConcat [ iStr "case ", iIndent (prettyPrintExprGen f 0 expr), iStr " of", iNewline 272 | , iStr " ", iIndent (prettyPrintAlternativesGen f alters) 273 | ] 274 | prettyPrintExprGen f _ (ELam vars expr) 275 | = iConcat [ iStr "\\ ", prettyPrintVarsGen f vars, iStr " .", iNewline 276 | , iStr " ", iIndent (prettyPrintExprGen f 0 expr) 277 | ] 278 | prettyPrintExprGen _ _ (EConstr t a) 279 | = iConcat [ iStr "Pack{", iNum t, iStr ",", iNum a, iStr "}" ] 280 | 281 | prettyPrintDefinitionsGen :: (a -> ISeq) -> Assoc a (Expr a) -> ISeq 282 | prettyPrintDefinitionsGen f defns 283 | = iInterleave sep (map (prettyPrintDefinitionGen f) defns) 284 | where 285 | sep = iConcat [ iStr ";", iNewline ] 286 | 287 | prettyPrintDefinitionGen :: (a -> ISeq) -> (a, Expr a) -> ISeq 288 | prettyPrintDefinitionGen f (name, expr) 289 | = iConcat [ f name, iStr " = ", iIndent (prettyPrintExprGen f 0 expr) ] 290 | 291 | 292 | prettyPrintAlternativesGen :: (a -> ISeq) -> [Alter a] -> ISeq 293 | prettyPrintAlternativesGen f alters 294 | = iInterleave sep (map (prettyPrintAlternativeGen f) alters) 295 | where 296 | sep = iConcat [ iStr ";", iNewline ] 297 | 298 | prettyPrintAlternativeGen :: (a -> ISeq) -> Alter a -> ISeq 299 | prettyPrintAlternativeGen f (tag, [], expr) 300 | = iConcat [ iStr "<", iStr (show tag), iStr "> -> ", iIndent (prettyPrintExprGen f 0 expr) ] 301 | prettyPrintAlternativeGen f (tag, vars, expr) 302 | = iConcat [ iStr "<", iStr (show tag), iStr "> ", prettyPrintVarsGen f vars, iStr " -> ", iIndent (prettyPrintExprGen f 0 expr) ] 303 | 304 | prettyPrintVarsGen :: (a -> ISeq) -> [a] -> ISeq 305 | prettyPrintVarsGen f vars 306 | = iInterleave (iStr " ") (map f vars) 307 | 308 | #if __CLH_EXERCISE_6__ >= 2 309 | prettyPrintAnnGen :: (a -> ISeq) -> (b -> ISeq) -> AnnProgram a b -> String 310 | prettyPrintAnnGen f g program = iDisplay (prettyPrintAnnProgramGen f g program) 311 | 312 | prettyPrintAnnProgramGen :: (a -> ISeq) -> (b -> ISeq) -> AnnProgram a b -> ISeq 313 | prettyPrintAnnProgramGen f g scdefns 314 | = iInterleave sep (map (prettyPrintAnnSupercombinatorDefinitionGen f g) scdefns) 315 | where 316 | sep = iConcat [ iStr ";", iNewline ] 317 | 318 | prettyPrintAnnSupercombinatorDefinitionGen :: (a -> ISeq) -> (b -> ISeq) -> AnnScDefn a b -> ISeq 319 | prettyPrintAnnSupercombinatorDefinitionGen f g (name, [], expr) 320 | = iConcat [ iStr name, iStr " = ", iIndent (prettyPrintAnnExprGen f g 0 expr) ] 321 | prettyPrintAnnSupercombinatorDefinitionGen f g (name, vars, expr) 322 | = iConcat [ iStr name, iStr " ", prettyPrintAnnVarsGen f g vars, iStr " = ", iIndent (prettyPrintAnnExprGen f g 0 expr) ] 323 | 324 | prettyPrintAnnExprGen :: (a -> ISeq) -> (b -> ISeq) -> Int -> AnnExpr a b -> ISeq 325 | prettyPrintAnnExprGen f g prec (b, expr') 326 | = prettyPrintWith g b (prettyPrintAnnExpr'Gen f g prec expr') 327 | 328 | prettyPrintAnnExpr'Gen :: (a -> ISeq) -> (b -> ISeq) -> Int -> AnnExpr' a b -> ISeq 329 | prettyPrintAnnExpr'Gen _ _ _ (ANum n) = iNum n 330 | prettyPrintAnnExpr'Gen _ _ _ (AVar v) = iStr v 331 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar "|") e1) e2) 332 | = iPrecParen prec 1 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 2 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 1 e2 ] 333 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar "&") e1) e2) 334 | = iPrecParen prec 2 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 3 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 2 e2 ] 335 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar "==") e1) e2) 336 | = iPrecParen prec 3 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 4 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 4 e2 ] 337 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar "~=") e1) e2) 338 | = iPrecParen prec 3 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 4 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 4 e2 ] 339 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar ">") e1) e2) 340 | = iPrecParen prec 3 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 4 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 4 e2 ] 341 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar ">=") e1) e2) 342 | = iPrecParen prec 3 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 4 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 4 e2 ] 343 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar "<") e1) e2) 344 | = iPrecParen prec 3 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 4 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 4 e2 ] 345 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar "<=") e1) e2) 346 | = iPrecParen prec 3 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 4 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 4 e2 ] 347 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar "+") e1) e2) 348 | = iPrecParen prec 4 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 5 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 4 e2 ] 349 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar "-") e1) e2) 350 | = iPrecParen prec 4 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 5 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 5 e2 ] 351 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar "*") e1) e2) 352 | = iPrecParen prec 5 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 6 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 5 e2 ] 353 | prettyPrintAnnExpr'Gen f g prec (AAp (b, AAp eV@(_, AVar "/") e1) e2) 354 | = iPrecParen prec 5 . prettyPrintWith g b . iConcat $ [ prettyPrintAnnExprGen f g 6 e1, iStr " ", prettyPrintAnnExprGen f g 0 eV, iStr " ", prettyPrintAnnExprGen f g 6 e2 ] 355 | prettyPrintAnnExpr'Gen f g prec (AAp e1 e2) 356 | = iPrecParen prec 10 . iConcat $ [ prettyPrintAnnExprGen f g 10 e1, iStr " ", prettyPrintAnnExprGen f g 11 e2 ] 357 | prettyPrintAnnExpr'Gen f g _ (ALet isRec defns expr) 358 | = iConcat [ iStr keyword, iNewline 359 | , iStr " ", iIndent (prettyPrintAnnDefinitionsGen f g defns), iNewline 360 | , iStr "in ", prettyPrintAnnExprGen f g 0 expr 361 | ] 362 | where 363 | keyword 364 | | not isRec = "let" 365 | | otherwise = "letrec" 366 | prettyPrintAnnExpr'Gen f g _ (ACase expr alters) 367 | = iConcat [ iStr "case ", iIndent (prettyPrintAnnExprGen f g 0 expr), iStr " of", iNewline 368 | , iStr " ", iIndent (prettyPrintAnnAlternativesGen f g alters) 369 | ] 370 | prettyPrintAnnExpr'Gen f g _ (ALam vars expr) 371 | = iConcat [ iStr "\\ ", prettyPrintAnnVarsGen f g vars, iStr " .", iNewline 372 | , iStr " ", iIndent (prettyPrintAnnExprGen f g 0 expr) 373 | ] 374 | prettyPrintAnnExpr'Gen _ _ _ (AConstr t a) 375 | = iConcat [ iStr "Pack{", iNum t, iStr ",", iNum a, iStr "}" ] 376 | 377 | prettyPrintAnnDefinitionsGen :: (a -> ISeq) -> (b -> ISeq) -> Assoc a (AnnExpr a b) -> ISeq 378 | prettyPrintAnnDefinitionsGen f g defns 379 | = iInterleave sep (map (prettyPrintAnnDefinitionGen f g) defns) 380 | where 381 | sep = iConcat [ iStr ";", iNewline ] 382 | 383 | prettyPrintAnnDefinitionGen :: (a -> ISeq) -> (b -> ISeq) -> (a, AnnExpr a b) -> ISeq 384 | prettyPrintAnnDefinitionGen f g (name, expr) 385 | = iConcat [ f name, iStr " = ", iIndent (prettyPrintAnnExprGen f g 0 expr) ] 386 | 387 | 388 | prettyPrintAnnAlternativesGen :: (a -> ISeq) -> (b -> ISeq) -> [AnnAlter a b] -> ISeq 389 | prettyPrintAnnAlternativesGen f g alters 390 | = iInterleave sep (map (prettyPrintAnnAlternativeGen f g) alters) 391 | where 392 | sep = iConcat [ iStr ";", iNewline ] 393 | 394 | prettyPrintAnnAlternativeGen :: (a -> ISeq) -> (b -> ISeq) -> AnnAlter a b -> ISeq 395 | prettyPrintAnnAlternativeGen f g (tag, [], expr) 396 | = iConcat [ iStr "<", iStr (show tag), iStr "> -> ", iIndent (prettyPrintAnnExprGen f g 0 expr) ] 397 | prettyPrintAnnAlternativeGen f g (tag, vars, expr) 398 | = iConcat [ iStr "<", iStr (show tag), iStr "> ", prettyPrintAnnVarsGen f g vars, iStr " -> ", iIndent (prettyPrintAnnExprGen f g 0 expr) ] 399 | 400 | prettyPrintAnnVarsGen :: (a -> ISeq) -> (b -> ISeq) -> [a] -> ISeq 401 | prettyPrintAnnVarsGen f g vars 402 | = iInterleave (iStr " ") (map f vars) 403 | 404 | prettyPrintWith :: (a -> ISeq) -> a -> ISeq -> ISeq 405 | prettyPrintWith f a seq 406 | = iConcat [ iStr "(", f a, iStr ", ", seq, iStr ")" ] 407 | #endif 408 | #endif 409 | #else 410 | prettyPrint = undefined 411 | #endif 412 | #else 413 | prettyPrintAExpr = undefined 414 | prettyPrint = undefined 415 | #endif 416 | #else 417 | prettyPrint = undefined 418 | #endif 419 | -------------------------------------------------------------------------------- /src/Language/TiMachineAlter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Language.TiMachineAlter 3 | #if __CLH_EXERCISE_1__ >= 8 4 | ( run 5 | , compile 6 | , eval 7 | ) 8 | #endif 9 | where 10 | 11 | #if __CLH_EXERCISE_1__ >= 8 12 | import Data.ISeq 13 | import Data.List 14 | import Data.StatHeap 15 | import Language.Parser 16 | import Language.Prelude 17 | import Language.Types 18 | import Util 19 | 20 | run :: String -> String 21 | run = showResults . eval . compile . parse 22 | 23 | compile :: CoreProgram -> TiState 24 | compile program 25 | = ([], initialStack, initialTiDump, initialHeap, globals, tiStatInitial) 26 | where 27 | scDefs = program ++ preludeDefs ++ extraPreludeDefs 28 | 29 | (heap, globals) = buildInitialHeap scDefs 30 | (initialHeap, addressOfEntry) = statHAlloc heap (NAp addressOfPrintList addressOfMain) 31 | initialStack = [addressOfEntry] 32 | 33 | addressOfMain = aLookup globals "main" (error "main is not defined") 34 | addressOfPrintList = aLookup globals "printList" (error "printList is not defined") 35 | 36 | eval :: TiState -> [TiState] 37 | eval state 38 | = state : restStates 39 | where 40 | restStates 41 | | tiFinal state = [] 42 | | otherwise = eval nextState 43 | nextState = doAdmin (step state) 44 | 45 | showResults :: [TiState] -> String 46 | showResults states 47 | = iDisplay resultSeq 48 | where 49 | resultSeq 50 | = iConcat [ iLayn (map showState states) 51 | , showOutput (last states) 52 | , showStats (last states) 53 | ] 54 | 55 | type TiState = (TiOutput, TiStack, TiDump, TiHeap, TiGlobals, TiStats) 56 | 57 | type TiOutput = [Int] 58 | 59 | type TiStack = [Addr] 60 | 61 | #if __CLH_EXERCISE_2__ < 28 62 | type TiDump = [TiStack] 63 | 64 | initialTiDump :: TiDump 65 | initialTiDump = [] 66 | #endif 67 | 68 | type TiHeap = StatHeap Node 69 | 70 | type TiGlobals = Assoc Name Addr 71 | 72 | type TiStats 73 | = ( Int -- The number of steps 74 | , ( Int -- The number of supercombinator reduction 75 | , Int -- The number of primitive reduction 76 | ) 77 | , Int -- The maximun stack depth 78 | ) 79 | 80 | tiStatInitial :: TiStats 81 | tiStatInitial = (0, (0, 0), 0) 82 | tiStatIncSteps :: TiStats -> TiStats 83 | tiStatIncSteps (steps, redStats, maxStackDepth) 84 | = (steps + 1, redStats, maxStackDepth) 85 | tiStatGetSteps :: TiStats -> Int 86 | tiStatGetSteps (steps, _, _) = steps 87 | tiStatIncScReds :: TiStats -> TiStats 88 | tiStatIncScReds (steps, (scReds, pReds), maxStackDepth) 89 | = (steps, (scReds + 1, pReds), maxStackDepth) 90 | tiStatGetScReds :: TiStats -> Int 91 | tiStatGetScReds (_, (scReds, _), _) 92 | = scReds 93 | tiStatIncPReds :: TiStats -> TiStats 94 | tiStatIncPReds (steps, (scReds, pReds), maxStackDepth) 95 | = (steps, (scReds, pReds + 1), maxStackDepth) 96 | tiStatGetPReds :: TiStats -> Int 97 | tiStatGetPReds (_, (_, pReds), _) 98 | = pReds 99 | tiStatSetMaxStackDepth :: Int -> TiStats -> TiStats 100 | tiStatSetMaxStackDepth max (steps, (scReds, pReds), _) 101 | = (steps, (scReds, pReds), max) 102 | tiStatGetMaxStackDepth :: TiStats -> Int 103 | tiStatGetMaxStackDepth (_, _, maxStackDepth) 104 | = maxStackDepth 105 | 106 | applyToStats :: (TiStats -> TiStats) -> TiState -> TiState 107 | applyToStats statFun (output, stack, dump, heap, scDefs, stats) 108 | = (output, stack, dump, heap, scDefs, statFun stats) 109 | 110 | extraPreludeDefs :: CoreProgram 111 | #if __CLH_EXERCISE_2__ != 29 112 | extraPreludeDefs 113 | = [ ("False", [], EConstr 1 0) 114 | , ("True", [], EConstr 2 0) 115 | , ("and", ["x", "y"], EAp (EAp (EAp (EVar "if") (EVar "x")) (EVar "y")) (EVar "False")) 116 | , ("or", ["x", "y"], EAp (EAp (EAp (EVar "if") (EVar "x")) (EVar "True")) (EVar "y")) 117 | , ("xor", ["x", "y"], EAp (EAp (EAp (EVar "if") (EVar "x")) (EAp (EVar "not") (EVar "y"))) (EVar "y")) 118 | , ("not", ["y"], EAp (EAp (EAp (EVar "if") (EVar "y")) (EVar "False")) (EVar "True")) 119 | , ("MkPair", [], EConstr 1 2) 120 | , ("fst", ["p"], EAp (EAp (EVar "casePair") (EVar "p")) (EVar "K")) 121 | , ("snd", ["p"], EAp (EAp (EVar "casePair") (EVar "p")) (EVar "K1")) 122 | , ("Cons", [], EConstr 2 2) 123 | , ("Nil", [], EConstr 1 0) 124 | , ("head", ["l"], EAp (EAp (EAp (EVar "caseList") (EVar "l")) (EVar "abort")) (EVar "K")) 125 | , ("tail", ["l"], EAp (EAp (EAp (EVar "caseList") (EVar "l")) (EVar "abort")) (EVar "K1")) 126 | , ("printList", ["xs"], EAp (EAp (EAp (EVar "caseList") (EVar "xs")) (EVar "stop")) (EVar "printCons")) 127 | , ("printCons", ["h", "t"], EAp (EAp (EVar "print") (EVar "h")) (EAp (EVar "printList") (EVar "t"))) 128 | ] 129 | #endif 130 | 131 | buildInitialHeap :: [CoreScDefn] -> (TiHeap, TiGlobals) 132 | buildInitialHeap scDefs 133 | = (heap2, scAddrs ++ primAddrs) 134 | where 135 | (heap1, scAddrs) = mapAccumL allocateSc statHInitial scDefs 136 | (heap2, primAddrs) = mapAccumL allocatePrim heap1 primitives 137 | 138 | allocateSc :: TiHeap -> CoreScDefn -> (TiHeap, (Name, Addr)) 139 | allocateSc heap (name, args, body) 140 | = (heap', (name, addr)) 141 | where 142 | (heap', addr) = statHAlloc heap (NSc name args body) 143 | 144 | doAdmin :: TiState -> TiState 145 | doAdmin state@(_, stack, _, _, _, stats) 146 | = applyToStats (updateMaxStackDepth . tiStatIncSteps) state 147 | where 148 | updateMaxStackDepth 149 | | stackDepth <= statMaxStackDepth = id 150 | | otherwise = tiStatSetMaxStackDepth stackDepth 151 | 152 | stackDepth = length stack 153 | statMaxStackDepth = tiStatGetMaxStackDepth stats 154 | 155 | tiFinal :: TiState -> Bool 156 | tiFinal (_, [soleAddr], [], heap, _, _) = isDataNode (statHLookup heap soleAddr) 157 | tiFinal (_, [], _, _, _, _) = True 158 | tiFinal _ = False 159 | 160 | isDataNode :: Node -> Bool 161 | isDataNode (NNum n) = True 162 | isDataNode (NData tag args) = True 163 | isDataNode node = False 164 | 165 | step :: TiState -> TiState 166 | step state@(_, stack, _, heap, _, _) 167 | = dispatch (statHLookup heap (head stack)) 168 | where 169 | dispatch (NNum n) = numStep state n 170 | dispatch (NAp a1 a2) = apStep state a1 a2 171 | dispatch (NSc scName argNames body) 172 | = tiStatIncScReds `applyToStats` scStep state scName argNames body 173 | dispatch (NInd addr) = indStep state addr 174 | dispatch (NPrim _ prim) 175 | = tiStatIncPReds `applyToStats` primStep state prim 176 | dispatch (NData tag args) = dataStep state tag args 177 | 178 | numStep :: TiState -> Int -> TiState 179 | #if __CLH_EXERCISE_2__ < 28 180 | numStep (output, [_], stack : dump, heap, globals, stats) _ 181 | = (output, stack, dump, heap, globals, stats) 182 | numStep (_, stack, _ : _, heap, _, _) _ 183 | = error ("Wrong stack is detected : " ++ iDisplay (showStack heap stack)) 184 | numStep (_, _, dump, heap, _, _) _ 185 | = error ("Wrong dump is detected : " ++ iDisplay (iInterleave iNewline (map (showStack heap) dump))) 186 | #endif 187 | 188 | apStep :: TiState -> Addr -> Addr -> TiState 189 | apStep (output, stack@(topAddr : _), dump, heap, globals, stats) a1 a2 190 | = case arg of 191 | NInd a3 -> (output, stack, dump, makeHeap a3, globals, stats) 192 | _ -> (output, a1 : stack, dump, heap, globals, stats) 193 | where 194 | makeHeap = statHUpdate heap topAddr . NAp a1 195 | arg = statHLookup heap a2 196 | apStep _ _ _ = error "Empty stack for application is dectected" 197 | 198 | scStep :: TiState -> Name -> [Name] -> CoreExpr -> TiState 199 | #if __CLH_EXERCISE_2__ < 28 200 | scStep (output, stack, dump, heap, globals, stats) scName argNames body 201 | | argsLength + 1 <= length stack = (output, stack', dump, heap', globals, stats) 202 | | otherwise = error ("Two few arguments are provided to the function " ++ scName) 203 | where 204 | stack'@(rootAddr : _) = drop argsLength stack 205 | heap' = instantiateAndUpdate body rootAddr heap env 206 | env = argBindings ++ globals 207 | argBindings = zip argNames (getArgs heap stack) 208 | argsLength = length argNames 209 | #endif 210 | 211 | getArgs :: TiHeap -> TiStack -> [Addr] 212 | getArgs heap (_ : stack) 213 | = map getArg stack 214 | where 215 | getArg a 216 | = case statHLookup heap a of 217 | NAp _ arg -> arg 218 | _ -> error "Cannot get arg from non-application node" 219 | getArgs _ _ = error "Cannot get args from empty stack" 220 | 221 | instantiate :: CoreExpr -> TiHeap -> TiGlobals -> (TiHeap, Addr) 222 | instantiate (ENum n) heap env = statHAlloc heap (NNum n) 223 | instantiate (EAp e1 e2) heap env 224 | = statHAlloc heap2 (NAp a1 a2) 225 | where 226 | (heap1, a1) = instantiate e1 heap env 227 | (heap2, a2) = instantiate e2 heap1 env 228 | instantiate (EVar v) heap env 229 | = (heap, aLookup env v (error ("Undefined name " ++ v))) 230 | instantiate (EConstr tag arity) heap env 231 | = instantiateConstr tag arity heap env 232 | instantiate (ELet isRec defs body) heap env 233 | = instantiateLet isRec defs body heap env 234 | instantiate (ECase e alts) heap env 235 | = error "Can't instantiate case exprs" 236 | 237 | instantiateConstr :: Int -> Int -> TiHeap -> TiGlobals -> (TiHeap, Addr) 238 | #if __CLH_EXERCISE_2__ < 27 239 | instantiateConstr tag arity heap env = (heap', addr) 240 | where 241 | (heap', addr) = statHAlloc heap (NPrim "Pack" (PrimConstr tag arity)) 242 | #endif 243 | 244 | instantiateLet :: IsRec -> Assoc Name CoreExpr -> CoreExpr -> TiHeap -> TiGlobals -> (TiHeap, Addr) 245 | instantiateLet isRec defs body heap env = instantiate body heap' env' 246 | where 247 | (heap', defBindings) = mapAccumL allocateDef heap defs 248 | allocateDef = instantiateDef (if isRec then env' else env) 249 | env' = defBindings ++ env 250 | 251 | instantiateDef :: TiGlobals -> TiHeap -> (Name, CoreExpr) -> (TiHeap, (Name, Addr)) 252 | instantiateDef env heap (name, body) 253 | = (heap', (name, addr)) 254 | where 255 | (heap', addr) = instantiate body heap env 256 | 257 | showState :: TiState -> ISeq 258 | showState (_, stack, _, heap, _, _) 259 | = iConcat [ showStack heap stack, iNewline 260 | , iStr "Heap Size: ", iNum (statHSize heap), iNewline 261 | ] 262 | 263 | showStack :: TiHeap -> TiStack -> ISeq 264 | showStack heap stack 265 | = iConcat [ iStr "Stk [" 266 | , iIndent (iInterleave iNewline (map showStackItem stack)) 267 | , iStr "]" 268 | ] 269 | where 270 | showStackItem addr 271 | = iConcat [ showFWAddr addr, iStr ": ", showStkNode heap (statHLookup heap addr) ] 272 | 273 | showStkNode :: TiHeap -> Node -> ISeq 274 | showStkNode heap (NAp funAddr argAddr) 275 | = iConcat [ iStr "NAp ", showFWAddr funAddr, iStr " ", showFWAddr argAddr 276 | , iStr " (", showNode heap (statHLookup heap argAddr), iStr ")" 277 | ] 278 | showStkNode heap node = showNode heap node 279 | 280 | -- | 281 | -- Name is changed from `showAddr` to `showAddrToSeq` to avoid 282 | -- name collision. 283 | showAddrToSeq :: Addr -> ISeq 284 | showAddrToSeq addr = iStr (showAddr addr) 285 | 286 | showFWAddr :: Addr -> ISeq 287 | showFWAddr addr = iStr (space (4 - length str) ++ str) 288 | where 289 | str = showAddr addr 290 | 291 | showStats :: TiState -> ISeq 292 | showStats (_, _, _, heap, _, stats) 293 | = iConcat [ iNewline 294 | , iNewline 295 | , iStr "Total number of steps : ", iNum steps, iNewline 296 | , iNewline 297 | , iStr "Total number of reductions : ", iNum (scReds + pReds), iNewline 298 | , iStr "Total number of supercombinator reductions : ", iNum scReds, iNewline 299 | , iStr "Total number of primitive reductions : ", iNum pReds, iNewline 300 | , showStatHeapStats heap, iNewline 301 | , iNewline 302 | , iStr "Maximum stack depth : ", iNum maxStackDepth 303 | ] 304 | where 305 | steps = tiStatGetSteps stats 306 | scReds = tiStatGetScReds stats 307 | pReds = tiStatGetPReds stats 308 | maxStackDepth = tiStatGetMaxStackDepth stats 309 | 310 | showHeap :: TiHeap -> ISeq 311 | showHeap heap 312 | = iConcat [ iStr "Heap [" 313 | , iIndent (iInterleave iNewline (map showHeapItem (statHAddresses heap))) 314 | , iStr "]" 315 | ] 316 | where 317 | showHeapItem addr 318 | = iConcat [ showFWAddr addr, iStr ": ", showStkNode heap (statHLookup heap addr) ] 319 | 320 | showStatHeapStats :: TiHeap -> ISeq 321 | showStatHeapStats heap 322 | = iConcat [ iNewline 323 | , iStr "Total number of heap allocations : ", iNum allocations, iNewline 324 | , iStr "Total number of heap updates : ", iNum updates, iNewline 325 | , iStr "Total number of heap frees : ", iNum frees 326 | ] 327 | where 328 | allocations = statHSGetHAlloc stats 329 | updates = statHSGetHUpdate stats 330 | frees = statHSGetHFree stats 331 | stats = statHGetStats heap 332 | 333 | showNode :: TiHeap -> Node -> ISeq 334 | showNode _ (NAp a1 a2) 335 | = iConcat [ iStr "NAp ", showAddrToSeq a1, iStr " ", showAddrToSeq a2 ] 336 | showNode _ (NSc scName argNames body) = iStr ("NSc " ++ scName) 337 | showNode _ (NNum n) = iStr "NNum " `iAppend` iNum n 338 | showNode heap (NInd a) 339 | = iConcat [ iStr "NInd (", showNode heap (statHLookup heap a), iStr ")" ] 340 | showNode heap (NPrim name _) 341 | = iConcat [ iStr "NPrim ", iStr name ] 342 | showNode heap (NData tag args) 343 | = iConcat [ iStr "NData ", iNum tag, iStr ", ", iInterleave (iStr " ") (map showFWAddr args) ] 344 | 345 | indStep :: TiState -> Addr -> TiState 346 | indStep (output, _ : stack, dump, heap, globals, stats) addr 347 | = (output, addr : stack, dump, heap, globals, stats) 348 | indStep _ _ = error "Wrong stack!" 349 | 350 | instantiateAndUpdate :: CoreExpr -> Addr -> TiHeap -> TiGlobals -> TiHeap 351 | instantiateAndUpdate (EAp e1 e2) updateAddr heap env 352 | = statHUpdate heap2 updateAddr (NAp a1 a2) 353 | where 354 | (heap1, a1) = instantiate e1 heap env 355 | (heap2, a2) = instantiate e2 heap1 env 356 | instantiateAndUpdate (ENum n) updateAddr heap env = statHUpdate heap updateAddr (NNum n) 357 | instantiateAndUpdate (EVar v) updateAddr heap env 358 | = statHUpdate heap updateAddr (NInd vAddr) 359 | where 360 | vAddr = aLookup env v (error ("Undefined name " ++ v)) 361 | instantiateAndUpdate (EConstr tag arity) updateAddr heap env 362 | = instantiateAndUpdateConstr tag arity updateAddr heap env 363 | instantiateAndUpdate (ELet isRec defs body) updateAddr heap env 364 | = instantiateAndUpdateLet isRec defs body updateAddr heap env 365 | instantiateAndUpdate (ECase e alts) updateAddr heap env 366 | = error "Can't instantiate case exprs" 367 | 368 | instantiateAndUpdateConstr :: Int -> Int -> Addr -> TiHeap -> TiGlobals -> TiHeap 369 | #if __CLH_EXERCISE_2__ < 27 370 | instantiateAndUpdateConstr tag arity addr heap env = heap' 371 | where 372 | heap' = statHUpdate heap addr (NPrim "Pack" (PrimConstr tag arity)) 373 | #endif 374 | 375 | instantiateAndUpdateLet :: IsRec -> Assoc Name CoreExpr -> CoreExpr -> Addr -> TiHeap -> TiGlobals -> TiHeap 376 | instantiateAndUpdateLet isRec defs body addr heap env = instantiateAndUpdate body addr heap' env' 377 | where 378 | (heap', defBindings) = mapAccumL allocateDef heap defs 379 | allocateDef = instantiateDef (if isRec then env' else env) 380 | env' = defBindings ++ env 381 | 382 | #if __CLH_EXERCISE_2__ < 27 383 | data Primitive 384 | = Neg 385 | | Add 386 | | Sub 387 | | Mul 388 | | Div 389 | | PrimConstr Int Int 390 | | If 391 | | Greater 392 | | GreaterEq 393 | | Less 394 | | LessEq 395 | | Eq 396 | | NotEq 397 | | CasePair 398 | | CaseList 399 | | Abort 400 | | Stop 401 | | Print 402 | #endif 403 | 404 | primitives :: Assoc Name Primitive 405 | #if __CLH_EXERCISE_2__ < 27 406 | primitives 407 | = [ ("negate", Neg) 408 | , ("+", Add), ("-", Sub) 409 | , ("*", Mul), ("/", Div) 410 | , ("if", If) 411 | , (">", Greater), (">=", GreaterEq) 412 | , ("<", Less), ("<=", LessEq) 413 | , ("==", Eq), ("~=", NotEq) 414 | , ("casePair", CasePair) 415 | , ("caseList", CaseList) 416 | , ("abort", Abort) 417 | , ("stop", Stop) 418 | , ("print", Print) 419 | ] 420 | #endif 421 | 422 | allocatePrim :: TiHeap -> (Name, Primitive) -> (TiHeap, (Name, Addr)) 423 | allocatePrim heap (name, prim) = (heap', (name, addr)) 424 | where 425 | (heap', addr) = statHAlloc heap (NPrim name prim) 426 | 427 | primStep :: TiState -> Primitive -> TiState 428 | #if __CLH_EXERCISE_2__ < 27 429 | primStep state Neg = primNeg state 430 | primStep state Add = primArith state (+) 431 | primStep state Sub = primArith state (-) 432 | primStep state Mul = primArith state (*) 433 | primStep state Div = primArith state div 434 | primStep state (PrimConstr tag arity) = primConstr state tag arity 435 | primStep state If = primIf state 436 | primStep state Greater = primComp state (>) 437 | primStep state GreaterEq = primComp state (>=) 438 | primStep state Less = primComp state (<) 439 | primStep state LessEq = primComp state (<=) 440 | primStep state Eq = primComp state (==) 441 | primStep state NotEq = primComp state (/=) 442 | primStep state CasePair = primCasePair state 443 | primStep state CaseList = primCaseList state 444 | primStep state Abort = error "Program is aborted by abort primitive" 445 | primStep state Stop = primStop state 446 | primStep state Print = primPrint state 447 | #endif 448 | 449 | -- Do we need to check stack length? 450 | -- It should be longer than or equal to 2 451 | primNeg :: TiState -> TiState 452 | #if __CLH_EXERCISE_2__ < 28 453 | primNeg (output, stack@(_ : _ : _), dump, heap, globals, stats) 454 | = case arg of 455 | NNum v -> (output, negApStack, dump, makeHeap v, globals, stats) 456 | _ 457 | | isDataNode arg -> error "Negation cannot be applied to other than numbers" 458 | | otherwise -> (output, [argAddr], negApStack : dump, heap, globals, stats) 459 | where 460 | _ : negApStack@(rootAddr : _) = stack 461 | 462 | makeHeap = statHUpdate heap rootAddr . NNum . negate 463 | 464 | argAddr : _ = getArgs heap stack 465 | arg = statHLookup heap argAddr 466 | primNeg _ = error "Wrong stack for negate is detected" 467 | #endif 468 | 469 | primArith :: TiState -> (Int -> Int -> Int) -> TiState 470 | primArith state f = primDyadic state nodeF 471 | where 472 | nodeF (NNum v1) (NNum v2) = NNum (f v1 v2) 473 | nodeF _ _ = error "Wrong data type for a binary arithmetic operation is detected" 474 | 475 | data Node 476 | = NAp Addr Addr 477 | | NSc Name [Name] CoreExpr 478 | | NNum Int 479 | | NInd Addr 480 | | NPrim Name Primitive 481 | | NData Int [Addr] 482 | 483 | dataStep :: TiState -> Int -> [Addr] -> TiState 484 | #if __CLH_EXERCISE_2__ < 28 485 | dataStep (output, [_], stack : dump, heap, globals, stats) _ _ 486 | = (output, stack, dump, heap, globals, stats) 487 | dataStep (_, stack, _ : _, heap, _, _) _ _ 488 | = error ("Wrong stack is detected : " ++ iDisplay (showStack heap stack)) 489 | dataStep (_, _, dump, heap, _, _) _ _ 490 | = error ("Wrong dump is detected : " ++ iDisplay (iInterleave iNewline (map (showStack heap) dump))) 491 | #endif 492 | 493 | primConstr :: TiState -> Int -> Int -> TiState 494 | #if __CLH_EXERCISE_2__ < 28 495 | primConstr (output, stack, dump, heap, globals, stats) tag arity 496 | | length stack >= arity + 1 = (output, stack', dump, heap', globals, stats) 497 | | otherwise = error "Wrong stack for data type construction is detected" 498 | where 499 | stack'@(rootAddr : _) = drop arity stack 500 | heap' = statHUpdate heap rootAddr (NData tag args) 501 | args = take arity $ getArgs heap stack 502 | #endif 503 | 504 | primIf :: TiState -> TiState 505 | #if __CLH_EXERCISE_2__ < 28 506 | primIf (output, stack@(_ : _ : _ : _ : _), dump, heap, globals, stats) 507 | = case cond of 508 | NData 1 [] -> (output, rootStack, dump, falseHeap, globals, stats) 509 | NData 2 [] -> (output, rootStack, dump, trueHeap, globals, stats) 510 | _ 511 | | isDataNode cond -> error "Wrong data type for if is detected" 512 | | otherwise -> (output, [condAddr], ifApStack : dump, heap, globals, stats) 513 | where 514 | trueHeap = statHUpdate heap rootAddr (NInd trueAddr) 515 | falseHeap = statHUpdate heap rootAddr (NInd falseAddr) 516 | 517 | _ : ifApStack = stack 518 | _ : _ : rootStack = ifApStack 519 | rootAddr : _ = rootStack 520 | 521 | condAddr : trueAddr : falseAddr : _ = getArgs heap stack 522 | cond = statHLookup heap condAddr 523 | primIf _ = error "Wrong stack for if is detected" 524 | #endif 525 | 526 | primComp :: TiState -> (Int -> Int -> Bool) -> TiState 527 | primComp state f = primDyadic state nodeF 528 | where 529 | nodeF (NNum v1) (NNum v2) 530 | | f v1 v2 = NData 2 [] 531 | | otherwise = NData 1 [] 532 | nodeF _ _ = error "Wrong data type for a binary comparison operation is detected" 533 | 534 | primDyadic :: TiState -> (Node -> Node -> Node) -> TiState 535 | #if __CLH_EXERCISE_2__ < 28 536 | primDyadic (output, stack@(_ : _ : _ : _), dump, heap, globals, stats) f 537 | | arg1IsDataNode && arg2IsDataNode = (output, ap2Stack, dump, heap', globals, stats) 538 | | arg2IsDataNode = (output, [arg1Addr], ap1Stack : dump, heap, globals, stats) 539 | | otherwise = (output, [arg2Addr], ap2Stack : dump, heap, globals, stats) 540 | where 541 | heap' = statHUpdate heap rootAddr (f arg1 arg2) 542 | 543 | _ : ap1Stack = stack 544 | _ : ap2Stack = ap1Stack 545 | rootAddr : _ = ap2Stack 546 | 547 | arg1Addr : arg2Addr : _ = getArgs heap stack 548 | arg1 = statHLookup heap arg1Addr 549 | arg2 = statHLookup heap arg2Addr 550 | arg1IsDataNode = isDataNode arg1 551 | arg2IsDataNode = isDataNode arg2 552 | primDyadic _ _ = error "Wrong stack for a binary operation is detected" 553 | #endif 554 | 555 | primCasePair :: TiState -> TiState 556 | #if __CLH_EXERCISE_2__ < 28 557 | primCasePair (output, stack@(_ : _ : _ : _), dump, heap, globals, stats) 558 | = case expr of 559 | NData 1 [arg1, arg2] -> (output, rootStack, dump, makeHeap arg1 arg2, globals, stats) 560 | _ 561 | | isDataNode expr -> error "Wrong data type for casePair is detected" 562 | | otherwise -> (output, [exprAddr], caseApStack : dump, heap, globals, stats) 563 | where 564 | makeHeap arg1 arg2 = statHUpdate heap' rootAddr (NAp funAddr' arg2) 565 | where 566 | (heap', funAddr') = statHAlloc heap (NAp funAddr arg1) 567 | 568 | _ : caseApStack = stack 569 | _ : rootStack = caseApStack 570 | rootAddr : _ = rootStack 571 | 572 | exprAddr : funAddr : _ = getArgs heap stack 573 | expr = statHLookup heap exprAddr 574 | primCasePair _ = error "Wrong stack for casePair is detected" 575 | #endif 576 | 577 | primCaseList :: TiState -> TiState 578 | #if __CLH_EXERCISE_2__ < 28 579 | primCaseList (output, stack@(_ : _ : _ : _ : _), dump, heap, globals, stats) 580 | = case expr of 581 | NData 1 [] -> (output, rootStack, dump, nilHeap, globals, stats) 582 | NData 2 [h, t] -> (output, rootStack, dump, makeConsHeap h t, globals, stats) 583 | _ 584 | | isDataNode expr -> error "Wrong data type for caseList is detected" 585 | | otherwise -> (output, [exprAddr], caseApStack : dump, heap, globals, stats) 586 | where 587 | nilHeap = statHUpdate heap rootAddr (NInd nilAddr) 588 | makeConsHeap h t = statHUpdate heap' rootAddr (NAp consAddr' t) 589 | where 590 | (heap', consAddr') = statHAlloc heap (NAp consAddr h) 591 | 592 | _ : caseApStack = stack 593 | _ : _ : rootStack = caseApStack 594 | rootAddr : _ = rootStack 595 | 596 | exprAddr : nilAddr : consAddr : _ = getArgs heap stack 597 | expr = statHLookup heap exprAddr 598 | primCaseList _ = error "Wrong stack for caseList is detected" 599 | #endif 600 | 601 | primStop :: TiState -> TiState 602 | primStop (output, [_], [], heap, globals, stats) 603 | = (output, [], [], heap, globals, stats) 604 | primStop (_, _, [], _, _, _) = error "Wrong stack for stop is dectected" 605 | primStop _ = error "Wrong dump for stop is dectected" 606 | 607 | primPrint :: TiState -> TiState 608 | #if __CLH_EXERCISE_2__ < 28 609 | primPrint (output, stack@[_, _, _], [], heap, globals, stats) 610 | = case arg1 of 611 | NNum v -> (v : output, [arg2Addr], [], heap, globals, stats) 612 | _ 613 | | isDataNode arg1 -> error "Wrong data type for print is detected" 614 | | otherwise -> (output, [arg1Addr], [arg1Stack], heap, globals, stats) 615 | where 616 | _ : _ : arg1Stack = stack 617 | arg1Addr : arg2Addr : _ = getArgs heap stack 618 | arg1 = statHLookup heap arg1Addr 619 | primPrint (_, _, [], _, _, _) = error "Wrong stack for print is dectected" 620 | primPrint _ = error "Wrong dump for print is dectected" 621 | #endif 622 | 623 | showOutput :: TiState -> ISeq 624 | showOutput (output, _, _, _, _, _) 625 | = iConcat [ iStr "[", iInterleave (iStr ", ") . map iNum . reverse $ output, iStr "]"] 626 | 627 | #if __CLH_EXERCISE_2__ >= 27 628 | type Primitive = TiState -> TiState 629 | 630 | #if __CLH_EXERCISE_2__ != 29 631 | primitives 632 | = [ ("negate", primNeg) 633 | , ("+", (flip primArith (+))), ("-", (flip primArith (-))) 634 | , ("*", (flip primArith (*))), ("/", (flip primArith div)) 635 | , ("if", primIf) 636 | , (">", (flip primComp (>))), (">=", (flip primComp (>=))) 637 | , ("<", (flip primComp (<))), ("<=", (flip primComp (<=))) 638 | , ("==", (flip primComp (==))), ("~=", (flip primComp (/=))) 639 | , ("casePair", primCasePair) 640 | , ("caseList", primCaseList) 641 | , ("abort", error "Program is aborted by abort primitive") 642 | , ("stop", primStop) 643 | , ("print", primPrint) 644 | ] 645 | #endif 646 | 647 | primStep state prim = prim state 648 | 649 | instantiateConstr tag arity heap env = (heap', addr) 650 | where 651 | (heap', addr) = statHAlloc heap (NPrim "Pack" (\state -> primConstr state tag arity)) 652 | 653 | instantiateAndUpdateConstr tag arity addr heap env = heap' 654 | where 655 | heap' = statHUpdate heap addr (NPrim "Pack" (\state -> primConstr state tag arity)) 656 | 657 | #if __CLH_EXERCISE_2__ >= 28 658 | type TiDump = [Int] 659 | 660 | initialTiDump :: TiDump 661 | initialTiDump = [] 662 | 663 | getCurrentStackLength :: TiStack -> TiDump -> Int 664 | getCurrentStackLength stack dump = length stack - lastDumpPoint 665 | where 666 | lastDumpPoint = case dump of 667 | [] -> 0 668 | p : _ -> p 669 | 670 | numStep (output, stack, stackPoint : dump, heap, globals, stats) _ 671 | | stackLength == stackPoint + 1 = (output, stack', dump, heap, globals, stats) 672 | | otherwise = error ("Wrong stack is detected : " ++ iDisplay (showStack heap stack)) 673 | where 674 | stack' = drop 1 stack 675 | 676 | stackLength = length stack 677 | numStep (_, _, dump, heap, _, _) _ 678 | = error ("Wrong dump is detected : " ++ iDisplay (iInterleave (iStr ", ") (map iNum dump))) 679 | 680 | primNeg (output, stack, dump, heap, globals, stats) 681 | | currentStackLength >= 2 = case arg of 682 | NNum v -> (output, negApStack, dump, makeHeap v, globals, stats) 683 | _ 684 | | isDataNode arg -> error "Negation cannot be applied to other than numbers" 685 | | otherwise -> (output, argAddr : negApStack, (stackLength - 1) : dump, heap, globals, stats); 686 | | otherwise = error "Wrong stack for negate is detected" 687 | where 688 | _ : negApStack@(rootAddr : _) = stack 689 | 690 | makeHeap = statHUpdate heap rootAddr . NNum . negate 691 | 692 | argAddr : _ = getArgs heap stack 693 | arg = statHLookup heap argAddr 694 | 695 | stackLength = length stack 696 | currentStackLength = getCurrentStackLength stack dump 697 | 698 | dataStep (output, stack, stackPoint : dump, heap, globals, stats) _ _ 699 | | stackLength == stackPoint + 1 = (output, stack', dump, heap, globals, stats) 700 | | otherwise = error ("Wrong stack is detected : " ++ iDisplay (showStack heap stack)) 701 | where 702 | stack' = drop 1 stack 703 | 704 | stackLength = length stack 705 | dataStep (_, _, dump, heap, _, _) _ _ 706 | = error ("Wrong dump is detected : " ++ iDisplay (iInterleave (iStr ", ") (map iNum dump))) 707 | 708 | primIf (output, stack, dump, heap, globals, stats) 709 | | currentStackLength >= 4 = case cond of 710 | NData 1 [] -> (output, rootStack, dump, falseHeap, globals, stats) 711 | NData 2 [] -> (output, rootStack, dump, trueHeap, globals, stats) 712 | _ 713 | | isDataNode cond -> error "Wrong data type for if is detected" 714 | | otherwise -> (output, condAddr : ifApStack, (stackLength - 1) : dump, heap, globals, stats); 715 | | otherwise = error "Wrong stack for if is detected" 716 | where 717 | trueHeap = statHUpdate heap rootAddr (NInd trueAddr) 718 | falseHeap = statHUpdate heap rootAddr (NInd falseAddr) 719 | 720 | _ : ifApStack = stack 721 | _ : _ : rootStack = ifApStack 722 | rootAddr : _ = rootStack 723 | 724 | condAddr : trueAddr : falseAddr : _ = getArgs heap stack 725 | cond = statHLookup heap condAddr 726 | 727 | stackLength = length stack 728 | currentStackLength = getCurrentStackLength stack dump 729 | 730 | primDyadic (output, stack, dump, heap, globals, stats) f 731 | | currentStackLength >= 3 = 732 | case (arg1IsDataNode, arg2IsDataNode) of 733 | (True, True) -> (output, ap2Stack, dump, heap', globals, stats) 734 | (_, True) -> (output, arg1Addr : ap1Stack, (stackLength - 1) : dump, heap, globals, stats) 735 | _ -> (output, arg2Addr : ap2Stack, (stackLength - 2) : dump, heap, globals, stats) 736 | | otherwise = error "Wrong stack for a binary operation is detected" 737 | where 738 | heap' = statHUpdate heap rootAddr (f arg1 arg2) 739 | 740 | _ : ap1Stack = stack 741 | _ : ap2Stack = ap1Stack 742 | rootAddr : _ = ap2Stack 743 | 744 | arg1Addr : arg2Addr : _ = getArgs heap stack 745 | arg1 = statHLookup heap arg1Addr 746 | arg2 = statHLookup heap arg2Addr 747 | arg1IsDataNode = isDataNode arg1 748 | arg2IsDataNode = isDataNode arg2 749 | 750 | stackLength = length stack 751 | currentStackLength = getCurrentStackLength stack dump 752 | 753 | primCasePair (output, stack, dump, heap, globals, stats) 754 | | currentStackLength >= 3 = case expr of 755 | NData 1 [arg1, arg2] -> (output, rootStack, dump, makeHeap arg1 arg2, globals, stats) 756 | _ 757 | | isDataNode expr -> error "Wrong data type for casePair is detected" 758 | | otherwise -> (output, exprAddr : caseApStack, (stackLength - 1) : dump, heap, globals, stats); 759 | | otherwise = error "Wrong stack for casePair is detected" 760 | where 761 | makeHeap arg1 arg2 = statHUpdate heap' rootAddr (NAp funAddr' arg2) 762 | where 763 | (heap', funAddr') = statHAlloc heap (NAp funAddr arg1) 764 | 765 | _ : caseApStack = stack 766 | _ : rootStack = caseApStack 767 | rootAddr : _ = rootStack 768 | 769 | exprAddr : funAddr : _ = getArgs heap stack 770 | expr = statHLookup heap exprAddr 771 | 772 | stackLength = length stack 773 | currentStackLength = getCurrentStackLength stack dump 774 | 775 | primCaseList (output, stack, dump, heap, globals, stats) 776 | | currentStackLength >= 4 = case expr of 777 | NData 1 [] -> (output, rootStack, dump, nilHeap, globals, stats) 778 | NData 2 [h, t] -> (output, rootStack, dump, makeConsHeap h t, globals, stats) 779 | _ 780 | | isDataNode expr -> error "Wrong data type for caseList is detected" 781 | | otherwise -> (output, exprAddr : caseApStack, (stackLength - 1) : dump, heap, globals, stats); 782 | | otherwise = error "Wrong stack for caseList is detected" 783 | where 784 | nilHeap = statHUpdate heap rootAddr (NInd nilAddr) 785 | makeConsHeap h t = statHUpdate heap' rootAddr (NAp consAddr' t) 786 | where 787 | (heap', consAddr') = statHAlloc heap (NAp consAddr h) 788 | 789 | _ : caseApStack = stack 790 | _ : _ : rootStack = caseApStack 791 | rootAddr : _ = rootStack 792 | 793 | exprAddr : nilAddr : consAddr : _ = getArgs heap stack 794 | expr = statHLookup heap exprAddr 795 | 796 | stackLength = length stack 797 | currentStackLength = getCurrentStackLength stack dump 798 | 799 | primPrint (output, stack, [], heap, globals, stats) 800 | | stackLength == 3 = case arg1 of 801 | NNum v -> (v : output, [arg2Addr], [], heap, globals, stats) 802 | _ 803 | | isDataNode arg1 -> error "Wrong data type for print is detected" 804 | | otherwise -> (output, arg1Addr :arg1Stack, [1], heap, globals, stats); 805 | | otherwise = error "Wrong stack for print is dectected" 806 | where 807 | _ : _ : arg1Stack = stack 808 | arg1Addr : arg2Addr : _ = getArgs heap stack 809 | arg1 = statHLookup heap arg1Addr 810 | 811 | stackLength = length stack 812 | primPrint _ = error "Wrong dump for print is dectected" 813 | 814 | scStep (output, stack, dump, heap, globals, stats) scName argNames body 815 | | argsLength + 1 <= currentStackLength = (output, stack', dump, heap', globals, stats) 816 | | otherwise = error ("Two few arguments are provided to the function " ++ scName) 817 | where 818 | stack'@(rootAddr : _) = drop argsLength stack 819 | heap' = instantiateAndUpdate body rootAddr heap env 820 | env = argBindings ++ globals 821 | argBindings = zip argNames (getArgs heap stack) 822 | argsLength = length argNames 823 | 824 | stackLength = length stack 825 | currentStackLength = getCurrentStackLength stack dump 826 | 827 | primConstr (output, stack, dump, heap, globals, stats) tag arity 828 | | currentStackLength >= arity + 1 = (output, stack', dump, heap', globals, stats) 829 | | otherwise = error "Wrong stack for data type construction is detected" 830 | where 831 | stack'@(rootAddr : _) = drop arity stack 832 | heap' = statHUpdate heap rootAddr (NData tag args) 833 | args = take arity $ getArgs heap stack 834 | 835 | stackLength = length stack 836 | currentStackLength = getCurrentStackLength stack dump 837 | 838 | #if __CLH_EXERCISE_2__ == 29 839 | extraPreludeDefs 840 | = [ ("False", ["t", "f"], EVar "f") 841 | , ("True", ["t", "f"], EVar "t") 842 | , ("if", [], EVar "I") 843 | , ("and", ["b1", "b2", "t", "f"], EAp (EAp (EVar "b1") (EAp (EAp (EVar "b2") (EVar "t")) (EVar "f"))) (EVar "f")) 844 | , ("or", ["b1", "b2", "t", "f"], EAp (EAp (EVar "b1") (EVar "t")) (EAp (EAp (EVar "b2") (EVar "t")) (EVar "f"))) 845 | , ("xor", ["b1", "b2", "t", "f"], EAp (EAp (EVar "b1") (EAp (EAp (EVar "b2") (EVar "f")) (EVar "t"))) (EAp (EAp (EVar "b2") (EVar "t")) (EVar "f"))) 846 | , ("not", ["b", "t", "f"], EAp (EAp (EVar "b") (EVar "f")) (EVar "t")) 847 | , ("pair", ["a", "b", "f"], EAp (EAp (EVar "f") (EVar "a")) (EVar "b")) 848 | , ("casePair", [], EVar "I") 849 | , ("fst", ["p"], EAp (EVar "p") (EVar "K")) 850 | , ("snd", ["p"], EAp (EVar "p") (EVar "K1")) 851 | , ("cons", ["a", "b", "cn", "cc"], EAp (EAp (EVar "cc") (EVar "a")) (EVar "b")) 852 | , ("nil", ["cn", "cc"], EVar "cn") 853 | , ("caseList", [], EVar "I") 854 | , ("head", ["l"], EAp (EAp (EAp (EVar "caseList") (EVar "l")) (EVar "abort")) (EVar "K")) 855 | , ("tail", ["l"], EAp (EAp (EAp (EVar "caseList") (EVar "l")) (EVar "abort")) (EVar "K1")) 856 | , ("printList", ["xs"], EAp (EAp (EAp (EVar "caseList") (EVar "xs")) (EVar "stop")) (EVar "printCons")) 857 | , ("printCons", ["h", "t"], EAp (EAp (EVar "print") (EVar "h")) (EAp (EVar "printList") (EVar "t"))) 858 | ] 859 | 860 | primitives 861 | = [ ("negate", primNeg) 862 | , ("+", (flip primArith (+))), ("-", (flip primArith (-))) 863 | , ("*", (flip primArith (*))), ("/", (flip primArith div)) 864 | , (">", (flip primComp (>))), (">=", (flip primComp (>=))) 865 | , ("<", (flip primComp (<))), ("<=", (flip primComp (<=))) 866 | , ("==", (flip primComp (==))), ("~=", (flip primComp (/=))) 867 | , ("abort", error "Program is aborted by abort primitive") 868 | , ("stop", primStop) 869 | , ("print", primPrint) 870 | ] 871 | #endif 872 | #endif 873 | #endif 874 | #endif 875 | -------------------------------------------------------------------------------- /src/Language/TiMachineGC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Language.TiMachineGC 3 | #if __CLH_EXERCISE_1__ >= 8 4 | ( run 5 | , compile 6 | , eval 7 | ) 8 | #endif 9 | where 10 | 11 | #if __CLH_EXERCISE_1__ >= 8 12 | import Control.Arrow 13 | import Data.ISeq 14 | import Data.List 15 | import Data.StatHeap 16 | import Data.Tuple 17 | import Language.Parser 18 | import Language.Prelude 19 | import Language.Types 20 | import Util 21 | 22 | run :: String -> String 23 | run = showResults . eval . compile . parse 24 | 25 | compile :: CoreProgram -> TiState 26 | compile program 27 | = ([], initialStack, initialTiDump, initialHeap, globals, tiStatInitial) 28 | where 29 | scDefs = program ++ preludeDefs ++ extraPreludeDefs 30 | 31 | (heap, globals) = buildInitialHeap scDefs 32 | (initialHeap, addressOfEntry) = statHAlloc heap (NAp addressOfPrintList addressOfMain) 33 | initialStack = [addressOfEntry] 34 | 35 | addressOfMain = aLookup globals "main" (error "main is not defined") 36 | addressOfPrintList = aLookup globals "printList" (error "printList is not defined") 37 | 38 | eval :: TiState -> [TiState] 39 | eval state 40 | = state : restStates 41 | where 42 | restStates 43 | | tiFinal state = [] 44 | | otherwise = eval nextState 45 | nextState = doAdmin (step state) 46 | 47 | showResults :: [TiState] -> String 48 | showResults states 49 | = iDisplay resultSeq 50 | where 51 | resultSeq 52 | = iConcat [ iLayn (map showState states) 53 | , showOutput (last states) 54 | , showStats (last states) 55 | ] 56 | 57 | type TiState = (TiOutput, TiStack, TiDump, TiHeap, TiGlobals, TiStats) 58 | 59 | type TiOutput = [Int] 60 | 61 | type TiStack = [Addr] 62 | 63 | type TiDump = [TiStack] 64 | 65 | initialTiDump :: TiDump 66 | initialTiDump = [] 67 | 68 | type TiHeap = StatHeap Node 69 | 70 | type TiGlobals = Assoc Name Addr 71 | 72 | type TiStats 73 | = ( Int -- The number of steps 74 | , ( Int -- The number of supercombinator reduction 75 | , Int -- The number of primitive reduction 76 | ) 77 | , Int -- The maximun stack depth 78 | ) 79 | 80 | tiStatInitial :: TiStats 81 | tiStatInitial = (0, (0, 0), 0) 82 | tiStatIncSteps :: TiStats -> TiStats 83 | tiStatIncSteps (steps, redStats, maxStackDepth) 84 | = (steps + 1, redStats, maxStackDepth) 85 | tiStatGetSteps :: TiStats -> Int 86 | tiStatGetSteps (steps, _, _) = steps 87 | tiStatIncScReds :: TiStats -> TiStats 88 | tiStatIncScReds (steps, (scReds, pReds), maxStackDepth) 89 | = (steps, (scReds + 1, pReds), maxStackDepth) 90 | tiStatGetScReds :: TiStats -> Int 91 | tiStatGetScReds (_, (scReds, _), _) 92 | = scReds 93 | tiStatIncPReds :: TiStats -> TiStats 94 | tiStatIncPReds (steps, (scReds, pReds), maxStackDepth) 95 | = (steps, (scReds, pReds + 1), maxStackDepth) 96 | tiStatGetPReds :: TiStats -> Int 97 | tiStatGetPReds (_, (_, pReds), _) 98 | = pReds 99 | tiStatSetMaxStackDepth :: Int -> TiStats -> TiStats 100 | tiStatSetMaxStackDepth max (steps, (scReds, pReds), _) 101 | = (steps, (scReds, pReds), max) 102 | tiStatGetMaxStackDepth :: TiStats -> Int 103 | tiStatGetMaxStackDepth (_, _, maxStackDepth) 104 | = maxStackDepth 105 | 106 | applyToStats :: (TiStats -> TiStats) -> TiState -> TiState 107 | applyToStats statFun (output, stack, dump, heap, scDefs, stats) 108 | = (output, stack, dump, heap, scDefs, statFun stats) 109 | 110 | extraPreludeDefs :: CoreProgram 111 | extraPreludeDefs 112 | = [ ("False", [], EConstr 1 0) 113 | , ("True", [], EConstr 2 0) 114 | , ("and", ["x", "y"], EAp (EAp (EAp (EVar "if") (EVar "x")) (EVar "y")) (EVar "False")) 115 | , ("or", ["x", "y"], EAp (EAp (EAp (EVar "if") (EVar "x")) (EVar "True")) (EVar "y")) 116 | , ("xor", ["x", "y"], EAp (EAp (EAp (EVar "if") (EVar "x")) (EAp (EVar "not") (EVar "y"))) (EVar "y")) 117 | , ("not", ["y"], EAp (EAp (EAp (EVar "if") (EVar "y")) (EVar "False")) (EVar "True")) 118 | , ("MkPair", [], EConstr 1 2) 119 | , ("fst", ["p"], EAp (EAp (EVar "casePair") (EVar "p")) (EVar "K")) 120 | , ("snd", ["p"], EAp (EAp (EVar "casePair") (EVar "p")) (EVar "K1")) 121 | , ("Cons", [], EConstr 2 2) 122 | , ("Nil", [], EConstr 1 0) 123 | , ("head", ["l"], EAp (EAp (EAp (EVar "caseList") (EVar "l")) (EVar "abort")) (EVar "K")) 124 | , ("tail", ["l"], EAp (EAp (EAp (EVar "caseList") (EVar "l")) (EVar "abort")) (EVar "K1")) 125 | , ("printList", ["xs"], EAp (EAp (EAp (EVar "caseList") (EVar "xs")) (EVar "stop")) (EVar "printCons")) 126 | , ("printCons", ["h", "t"], EAp (EAp (EVar "print") (EVar "h")) (EAp (EVar "printList") (EVar "t"))) 127 | ] 128 | 129 | buildInitialHeap :: [CoreScDefn] -> (TiHeap, TiGlobals) 130 | buildInitialHeap scDefs 131 | = (heap2, scAddrs ++ primAddrs) 132 | where 133 | (heap1, scAddrs) = mapAccumL allocateSc statHInitial scDefs 134 | (heap2, primAddrs) = mapAccumL allocatePrim heap1 primitives 135 | 136 | allocateSc :: TiHeap -> CoreScDefn -> (TiHeap, (Name, Addr)) 137 | allocateSc heap (name, args, body) 138 | = (heap', (name, addr)) 139 | where 140 | (heap', addr) = statHAlloc heap (NSc name args body) 141 | 142 | doAdmin :: TiState -> TiState 143 | #if __CLH_EXERCISE_2__ < 30 144 | doAdmin state@(_, stack, _, _, _, stats) 145 | = applyToStats (updateMaxStackDepth . tiStatIncSteps) state 146 | where 147 | updateMaxStackDepth 148 | | stackDepth <= statMaxStackDepth = id 149 | | otherwise = tiStatSetMaxStackDepth stackDepth 150 | 151 | stackDepth = length stack 152 | statMaxStackDepth = tiStatGetMaxStackDepth stats 153 | #endif 154 | 155 | tiFinal :: TiState -> Bool 156 | tiFinal (_, [soleAddr], [], heap, _, _) = isDataNode (statHLookup heap soleAddr) 157 | tiFinal (_, [], _, _, _, _) = True 158 | tiFinal _ = False 159 | 160 | isDataNode :: Node -> Bool 161 | isDataNode (NNum n) = True 162 | isDataNode (NData tag args) = True 163 | isDataNode node = False 164 | 165 | step :: TiState -> TiState 166 | step state@(_, stack, _, heap, _, _) 167 | = dispatch (statHLookup heap (head stack)) 168 | where 169 | dispatch (NNum n) = numStep state n 170 | dispatch (NAp a1 a2) = apStep state a1 a2 171 | dispatch (NSc scName argNames body) 172 | = tiStatIncScReds `applyToStats` scStep state scName argNames body 173 | dispatch (NInd addr) = indStep state addr 174 | dispatch (NPrim _ prim) 175 | = tiStatIncPReds `applyToStats` primStep state prim 176 | dispatch (NData tag args) = dataStep state tag args 177 | 178 | numStep :: TiState -> Int -> TiState 179 | numStep (output, [_], stack : dump, heap, globals, stats) _ 180 | = (output, stack, dump, heap, globals, stats) 181 | numStep (_, stack, _ : _, heap, _, _) _ 182 | = error ("Wrong stack is detected : " ++ iDisplay (showStack heap stack)) 183 | numStep (_, _, dump, heap, _, _) _ 184 | = error ("Wrong dump is detected : " ++ iDisplay (iInterleave iNewline (map (showStack heap) dump))) 185 | 186 | apStep :: TiState -> Addr -> Addr -> TiState 187 | apStep (output, stack@(topAddr : _), dump, heap, globals, stats) a1 a2 188 | = case arg of 189 | NInd a3 -> (output, stack, dump, makeHeap a3, globals, stats) 190 | _ -> (output, a1 : stack, dump, heap, globals, stats) 191 | where 192 | makeHeap = statHUpdate heap topAddr . NAp a1 193 | arg = statHLookup heap a2 194 | apStep _ _ _ = error "Empty stack for application is dectected" 195 | 196 | scStep :: TiState -> Name -> [Name] -> CoreExpr -> TiState 197 | scStep (output, stack, dump, heap, globals, stats) scName argNames body 198 | | argsLength + 1 <= length stack = (output, stack', dump, heap', globals, stats) 199 | | otherwise = error ("Two few arguments are provided to the function " ++ scName) 200 | where 201 | stack'@(rootAddr : _) = drop argsLength stack 202 | heap' = instantiateAndUpdate body rootAddr heap env 203 | env = argBindings ++ globals 204 | argBindings = zip argNames (getArgs heap stack) 205 | argsLength = length argNames 206 | 207 | getArgs :: TiHeap -> TiStack -> [Addr] 208 | getArgs heap (_ : stack) 209 | = map getArg stack 210 | where 211 | getArg a 212 | = case statHLookup heap a of 213 | NAp _ arg -> arg 214 | _ -> error "Cannot get arg from non-application node" 215 | getArgs _ _ = error "Cannot get args from empty stack" 216 | 217 | instantiate :: CoreExpr -> TiHeap -> TiGlobals -> (TiHeap, Addr) 218 | instantiate (ENum n) heap env = statHAlloc heap (NNum n) 219 | instantiate (EAp e1 e2) heap env 220 | = statHAlloc heap2 (NAp a1 a2) 221 | where 222 | (heap1, a1) = instantiate e1 heap env 223 | (heap2, a2) = instantiate e2 heap1 env 224 | instantiate (EVar v) heap env 225 | = (heap, aLookup env v (error ("Undefined name " ++ v))) 226 | instantiate (EConstr tag arity) heap env 227 | = instantiateConstr tag arity heap env 228 | instantiate (ELet isRec defs body) heap env 229 | = instantiateLet isRec defs body heap env 230 | instantiate (ECase e alts) heap env 231 | = error "Can't instantiate case exprs" 232 | 233 | instantiateConstr :: Int -> Int -> TiHeap -> TiGlobals -> (TiHeap, Addr) 234 | instantiateConstr tag arity heap env = (heap', addr) 235 | where 236 | (heap', addr) = statHAlloc heap (NPrim "Pack" (PrimConstr tag arity)) 237 | 238 | instantiateLet :: IsRec -> Assoc Name CoreExpr -> CoreExpr -> TiHeap -> TiGlobals -> (TiHeap, Addr) 239 | instantiateLet isRec defs body heap env = instantiate body heap' env' 240 | where 241 | (heap', defBindings) = mapAccumL allocateDef heap defs 242 | allocateDef = instantiateDef (if isRec then env' else env) 243 | env' = defBindings ++ env 244 | 245 | instantiateDef :: TiGlobals -> TiHeap -> (Name, CoreExpr) -> (TiHeap, (Name, Addr)) 246 | instantiateDef env heap (name, body) 247 | = (heap', (name, addr)) 248 | where 249 | (heap', addr) = instantiate body heap env 250 | 251 | showState :: TiState -> ISeq 252 | showState (_, stack, _, heap, _, _) 253 | = iConcat [ showStack heap stack, iNewline 254 | , iStr "Heap Size: ", iNum (statHSize heap), iNewline 255 | ] 256 | 257 | showStack :: TiHeap -> TiStack -> ISeq 258 | showStack heap stack 259 | = iConcat [ iStr "Stk [" 260 | , iIndent (iInterleave iNewline (map showStackItem stack)) 261 | , iStr "]" 262 | ] 263 | where 264 | showStackItem addr 265 | = iConcat [ showFWAddr addr, iStr ": ", showStkNode heap (statHLookup heap addr) ] 266 | 267 | showStkNode :: TiHeap -> Node -> ISeq 268 | showStkNode heap (NAp funAddr argAddr) 269 | = iConcat [ iStr "NAp ", showFWAddr funAddr, iStr " ", showFWAddr argAddr 270 | , iStr " (", showNode heap (statHLookup heap argAddr), iStr ")" 271 | ] 272 | showStkNode heap node = showNode heap node 273 | 274 | -- | 275 | -- Name is changed from `showAddr` to `showAddrToSeq` to avoid 276 | -- name collision. 277 | showAddrToSeq :: Addr -> ISeq 278 | showAddrToSeq addr = iStr (showAddr addr) 279 | 280 | showFWAddr :: Addr -> ISeq 281 | showFWAddr addr = iStr (space (4 - length str) ++ str) 282 | where 283 | str = showAddr addr 284 | 285 | showStats :: TiState -> ISeq 286 | showStats (_, _, _, heap, _, stats) 287 | = iConcat [ iNewline 288 | , iNewline 289 | , iStr "Total number of steps : ", iNum steps, iNewline 290 | , iNewline 291 | , iStr "Total number of reductions : ", iNum (scReds + pReds), iNewline 292 | , iStr "Total number of supercombinator reductions : ", iNum scReds, iNewline 293 | , iStr "Total number of primitive reductions : ", iNum pReds, iNewline 294 | , showStatHeapStats heap, iNewline 295 | , iNewline 296 | , iStr "Maximum stack depth : ", iNum maxStackDepth, iNewline 297 | ] 298 | where 299 | steps = tiStatGetSteps stats 300 | scReds = tiStatGetScReds stats 301 | pReds = tiStatGetPReds stats 302 | maxStackDepth = tiStatGetMaxStackDepth stats 303 | 304 | showHeap :: TiHeap -> ISeq 305 | showHeap heap 306 | = iConcat [ iStr "Heap [" 307 | , iIndent (iInterleave iNewline (map showHeapItem (statHAddresses heap))) 308 | , iStr "]" 309 | ] 310 | where 311 | showHeapItem addr 312 | = iConcat [ showFWAddr addr, iStr ": ", showStkNode heap (statHLookup heap addr) ] 313 | 314 | showStatHeapStats :: TiHeap -> ISeq 315 | showStatHeapStats heap 316 | = iConcat [ iNewline 317 | , iStr "Total number of heap allocations : ", iNum allocations, iNewline 318 | , iStr "Total number of heap updates : ", iNum updates, iNewline 319 | , iStr "Total number of heap frees : ", iNum frees 320 | ] 321 | where 322 | allocations = statHSGetHAlloc stats 323 | updates = statHSGetHUpdate stats 324 | frees = statHSGetHFree stats 325 | stats = statHGetStats heap 326 | 327 | showNode :: TiHeap -> Node -> ISeq 328 | #if __CLH_EXERCISE_2__ < 32 329 | showNode _ (NAp a1 a2) 330 | = iConcat [ iStr "NAp ", showAddrToSeq a1, iStr " ", showAddrToSeq a2 ] 331 | showNode _ (NSc scName argNames body) = iStr ("NSc " ++ scName) 332 | showNode _ (NNum n) = iStr "NNum " `iAppend` iNum n 333 | showNode heap (NInd a) 334 | = iConcat [ iStr "NInd (", showNode heap (statHLookup heap a), iStr ")" ] 335 | showNode heap (NPrim name _) 336 | = iConcat [ iStr "NPrim ", iStr name ] 337 | showNode heap (NData tag args) 338 | = iConcat [ iStr "NData ", iNum tag, iStr ", ", iInterleave (iStr " ") (map showFWAddr args) ] 339 | #endif 340 | 341 | indStep :: TiState -> Addr -> TiState 342 | indStep (output, _ : stack, dump, heap, globals, stats) addr 343 | = (output, addr : stack, dump, heap, globals, stats) 344 | indStep _ _ = error "Wrong stack!" 345 | 346 | instantiateAndUpdate :: CoreExpr -> Addr -> TiHeap -> TiGlobals -> TiHeap 347 | instantiateAndUpdate (EAp e1 e2) updateAddr heap env 348 | = statHUpdate heap2 updateAddr (NAp a1 a2) 349 | where 350 | (heap1, a1) = instantiate e1 heap env 351 | (heap2, a2) = instantiate e2 heap1 env 352 | instantiateAndUpdate (ENum n) updateAddr heap env = statHUpdate heap updateAddr (NNum n) 353 | instantiateAndUpdate (EVar v) updateAddr heap env 354 | = statHUpdate heap updateAddr (NInd vAddr) 355 | where 356 | vAddr = aLookup env v (error ("Undefined name " ++ v)) 357 | instantiateAndUpdate (EConstr tag arity) updateAddr heap env 358 | = instantiateAndUpdateConstr tag arity updateAddr heap env 359 | instantiateAndUpdate (ELet isRec defs body) updateAddr heap env 360 | = instantiateAndUpdateLet isRec defs body updateAddr heap env 361 | instantiateAndUpdate (ECase e alts) updateAddr heap env 362 | = error "Can't instantiate case exprs" 363 | 364 | instantiateAndUpdateConstr :: Int -> Int -> Addr -> TiHeap -> TiGlobals -> TiHeap 365 | instantiateAndUpdateConstr tag arity addr heap env = heap' 366 | where 367 | heap' = statHUpdate heap addr (NPrim "Pack" (PrimConstr tag arity)) 368 | 369 | instantiateAndUpdateLet :: IsRec -> Assoc Name CoreExpr -> CoreExpr -> Addr -> TiHeap -> TiGlobals -> TiHeap 370 | instantiateAndUpdateLet isRec defs body addr heap env = instantiateAndUpdate body addr heap' env' 371 | where 372 | (heap', defBindings) = mapAccumL allocateDef heap defs 373 | allocateDef = instantiateDef (if isRec then env' else env) 374 | env' = defBindings ++ env 375 | 376 | data Primitive 377 | = Neg 378 | | Add 379 | | Sub 380 | | Mul 381 | | Div 382 | | PrimConstr Int Int 383 | | If 384 | | Greater 385 | | GreaterEq 386 | | Less 387 | | LessEq 388 | | Eq 389 | | NotEq 390 | | CasePair 391 | | CaseList 392 | | Abort 393 | | Stop 394 | | Print 395 | 396 | primitives :: Assoc Name Primitive 397 | primitives 398 | = [ ("negate", Neg) 399 | , ("+", Add), ("-", Sub) 400 | , ("*", Mul), ("/", Div) 401 | , ("if", If) 402 | , (">", Greater), (">=", GreaterEq) 403 | , ("<", Less), ("<=", LessEq) 404 | , ("==", Eq), ("~=", NotEq) 405 | , ("casePair", CasePair) 406 | , ("caseList", CaseList) 407 | , ("abort", Abort) 408 | , ("stop", Stop) 409 | , ("print", Print) 410 | ] 411 | 412 | allocatePrim :: TiHeap -> (Name, Primitive) -> (TiHeap, (Name, Addr)) 413 | allocatePrim heap (name, prim) = (heap', (name, addr)) 414 | where 415 | (heap', addr) = statHAlloc heap (NPrim name prim) 416 | 417 | primStep :: TiState -> Primitive -> TiState 418 | primStep state Neg = primNeg state 419 | primStep state Add = primArith state (+) 420 | primStep state Sub = primArith state (-) 421 | primStep state Mul = primArith state (*) 422 | primStep state Div = primArith state div 423 | primStep state (PrimConstr tag arity) = primConstr state tag arity 424 | primStep state If = primIf state 425 | primStep state Greater = primComp state (>) 426 | primStep state GreaterEq = primComp state (>=) 427 | primStep state Less = primComp state (<) 428 | primStep state LessEq = primComp state (<=) 429 | primStep state Eq = primComp state (==) 430 | primStep state NotEq = primComp state (/=) 431 | primStep state CasePair = primCasePair state 432 | primStep state CaseList = primCaseList state 433 | primStep state Abort = error "Program is aborted by abort primitive" 434 | primStep state Stop = primStop state 435 | primStep state Print = primPrint state 436 | 437 | -- Do we need to check stack length? 438 | -- It should be longer than or equal to 2 439 | primNeg :: TiState -> TiState 440 | primNeg (output, stack@(_ : _ : _), dump, heap, globals, stats) 441 | = case arg of 442 | NNum v -> (output, negApStack, dump, makeHeap v, globals, stats) 443 | _ 444 | | isDataNode arg -> error "Negation cannot be applied to other than numbers" 445 | | otherwise -> (output, [argAddr], negApStack : dump, heap, globals, stats) 446 | where 447 | _ : negApStack@(rootAddr : _) = stack 448 | 449 | makeHeap = statHUpdate heap rootAddr . NNum . negate 450 | 451 | argAddr : _ = getArgs heap stack 452 | arg = statHLookup heap argAddr 453 | primNeg _ = error "Wrong stack for negate is detected" 454 | 455 | primArith :: TiState -> (Int -> Int -> Int) -> TiState 456 | primArith state f = primDyadic state nodeF 457 | where 458 | nodeF (NNum v1) (NNum v2) = NNum (f v1 v2) 459 | nodeF _ _ = error "Wrong data type for a binary arithmetic operation is detected" 460 | 461 | #if __CLH_EXERCISE_2__ < 32 462 | data Node 463 | = NAp Addr Addr 464 | | NSc Name [Name] CoreExpr 465 | | NNum Int 466 | | NInd Addr 467 | | NPrim Name Primitive 468 | | NData Int [Addr] 469 | #endif 470 | 471 | dataStep :: TiState -> Int -> [Addr] -> TiState 472 | dataStep (output, [_], stack : dump, heap, globals, stats) _ _ 473 | = (output, stack, dump, heap, globals, stats) 474 | dataStep (_, stack, _ : _, heap, _, _) _ _ 475 | = error ("Wrong stack is detected : " ++ iDisplay (showStack heap stack)) 476 | dataStep (_, _, dump, heap, _, _) _ _ 477 | = error ("Wrong dump is detected : " ++ iDisplay (iInterleave iNewline (map (showStack heap) dump))) 478 | 479 | primConstr :: TiState -> Int -> Int -> TiState 480 | primConstr (output, stack, dump, heap, globals, stats) tag arity 481 | | length stack >= arity + 1 = (output, stack', dump, heap', globals, stats) 482 | | otherwise = error "Wrong stack for data type construction is detected" 483 | where 484 | stack'@(rootAddr : _) = drop arity stack 485 | heap' = statHUpdate heap rootAddr (NData tag args) 486 | args = take arity $ getArgs heap stack 487 | 488 | primIf :: TiState -> TiState 489 | primIf (output, stack@(_ : _ : _ : _ : _), dump, heap, globals, stats) 490 | = case cond of 491 | NData 1 [] -> (output, rootStack, dump, falseHeap, globals, stats) 492 | NData 2 [] -> (output, rootStack, dump, trueHeap, globals, stats) 493 | _ 494 | | isDataNode cond -> error "Wrong data type for if is detected" 495 | | otherwise -> (output, [condAddr], ifApStack : dump, heap, globals, stats) 496 | where 497 | trueHeap = statHUpdate heap rootAddr (NInd trueAddr) 498 | falseHeap = statHUpdate heap rootAddr (NInd falseAddr) 499 | 500 | _ : ifApStack = stack 501 | _ : _ : rootStack = ifApStack 502 | rootAddr : _ = rootStack 503 | 504 | condAddr : trueAddr : falseAddr : _ = getArgs heap stack 505 | cond = statHLookup heap condAddr 506 | primIf _ = error "Wrong stack for if is detected" 507 | 508 | primComp :: TiState -> (Int -> Int -> Bool) -> TiState 509 | primComp state f = primDyadic state nodeF 510 | where 511 | nodeF (NNum v1) (NNum v2) 512 | | f v1 v2 = NData 2 [] 513 | | otherwise = NData 1 [] 514 | nodeF _ _ = error "Wrong data type for a binary comparison operation is detected" 515 | 516 | primDyadic :: TiState -> (Node -> Node -> Node) -> TiState 517 | primDyadic (output, stack@(_ : _ : _ : _), dump, heap, globals, stats) f 518 | | arg1IsDataNode && arg2IsDataNode = (output, ap2Stack, dump, heap', globals, stats) 519 | | arg2IsDataNode = (output, [arg1Addr], ap1Stack : dump, heap, globals, stats) 520 | | otherwise = (output, [arg2Addr], ap2Stack : dump, heap, globals, stats) 521 | where 522 | heap' = statHUpdate heap rootAddr (f arg1 arg2) 523 | 524 | _ : ap1Stack = stack 525 | _ : ap2Stack = ap1Stack 526 | rootAddr : _ = ap2Stack 527 | 528 | arg1Addr : arg2Addr : _ = getArgs heap stack 529 | arg1 = statHLookup heap arg1Addr 530 | arg2 = statHLookup heap arg2Addr 531 | arg1IsDataNode = isDataNode arg1 532 | arg2IsDataNode = isDataNode arg2 533 | primDyadic _ _ = error "Wrong stack for a binary operation is detected" 534 | 535 | primCasePair :: TiState -> TiState 536 | primCasePair (output, stack@(_ : _ : _ : _), dump, heap, globals, stats) 537 | = case expr of 538 | NData 1 [arg1, arg2] -> (output, rootStack, dump, makeHeap arg1 arg2, globals, stats) 539 | _ 540 | | isDataNode expr -> error "Wrong data type for casePair is detected" 541 | | otherwise -> (output, [exprAddr], caseApStack : dump, heap, globals, stats) 542 | where 543 | makeHeap arg1 arg2 = statHUpdate heap' rootAddr (NAp funAddr' arg2) 544 | where 545 | (heap', funAddr') = statHAlloc heap (NAp funAddr arg1) 546 | 547 | _ : caseApStack = stack 548 | _ : rootStack = caseApStack 549 | rootAddr : _ = rootStack 550 | 551 | exprAddr : funAddr : _ = getArgs heap stack 552 | expr = statHLookup heap exprAddr 553 | primCasePair _ = error "Wrong stack for casePair is detected" 554 | 555 | primCaseList :: TiState -> TiState 556 | primCaseList (output, stack@(_ : _ : _ : _ : _), dump, heap, globals, stats) 557 | = case expr of 558 | NData 1 [] -> (output, rootStack, dump, nilHeap, globals, stats) 559 | NData 2 [h, t] -> (output, rootStack, dump, makeConsHeap h t, globals, stats) 560 | _ 561 | | isDataNode expr -> error "Wrong data type for caseList is detected" 562 | | otherwise -> (output, [exprAddr], caseApStack : dump, heap, globals, stats) 563 | where 564 | nilHeap = statHUpdate heap rootAddr (NInd nilAddr) 565 | makeConsHeap h t = statHUpdate heap' rootAddr (NAp consAddr' t) 566 | where 567 | (heap', consAddr') = statHAlloc heap (NAp consAddr h) 568 | 569 | _ : caseApStack = stack 570 | _ : _ : rootStack = caseApStack 571 | rootAddr : _ = rootStack 572 | 573 | exprAddr : nilAddr : consAddr : _ = getArgs heap stack 574 | expr = statHLookup heap exprAddr 575 | primCaseList _ = error "Wrong stack for caseList is detected" 576 | 577 | primStop :: TiState -> TiState 578 | primStop (output, [_], [], heap, globals, stats) 579 | = (output, [], [], heap, globals, stats) 580 | primStop (_, _, [], _, _, _) = error "Wrong stack for stop is dectected" 581 | primStop _ = error "Wrong dump for stop is dectected" 582 | 583 | primPrint :: TiState -> TiState 584 | primPrint (output, stack@[_, _, _], [], heap, globals, stats) 585 | = case arg1 of 586 | NNum v -> (v : output, [arg2Addr], [], heap, globals, stats) 587 | _ 588 | | isDataNode arg1 -> error "Wrong data type for print is detected" 589 | | otherwise -> (output, [arg1Addr], [arg1Stack], heap, globals, stats) 590 | where 591 | _ : _ : arg1Stack = stack 592 | arg1Addr : arg2Addr : _ = getArgs heap stack 593 | arg1 = statHLookup heap arg1Addr 594 | primPrint (_, _, [], _, _, _) = error "Wrong stack for print is dectected" 595 | primPrint _ = error "Wrong dump for print is dectected" 596 | 597 | showOutput :: TiState -> ISeq 598 | showOutput (output, _, _, _, _, _) 599 | = iConcat [ iStr "[", iInterleave (iStr ", ") . map iNum . reverse $ output, iStr "]"] 600 | 601 | #if __CLH_EXERCISE_2__ >= 30 602 | gc :: TiState -> TiState 603 | 604 | #if __CLH_EXERCISE_2__ < 33 605 | findStackRoots :: TiStack -> [Addr] 606 | findDumpRoots :: TiDump -> [Addr] 607 | findGlobalRoots :: TiGlobals -> [Addr] 608 | 609 | markFrom :: TiHeap -> Addr -> TiHeap 610 | #endif 611 | 612 | scanHeap :: TiHeap -> TiHeap 613 | 614 | #if __CLH_EXERCISE_2__ < 33 615 | gc (output, stack, dump, heap, globals, stats) 616 | = (output, stack, dump, heap', globals, stats) 617 | where 618 | heap' = scanHeap . foldl markFrom heap $ roots 619 | 620 | roots = findStackRoots stack ++ findDumpRoots dump ++ findGlobalRoots globals 621 | #endif 622 | 623 | gcHeapSize :: Int 624 | #if __CLH_EXERCISE_2__ < 32 625 | gcHeapSize = 1000 626 | #endif 627 | 628 | doAdmin state@(_, stack, _, heap, _, stats) 629 | | statHSize heap < gcHeapSize = state' 630 | | otherwise = gc state' 631 | where 632 | state' = applyToStats (updateMaxStackDepth . tiStatIncSteps) state 633 | 634 | updateMaxStackDepth 635 | | stackDepth <= statMaxStackDepth = id 636 | | otherwise = tiStatSetMaxStackDepth stackDepth 637 | 638 | stackDepth = length stack 639 | statMaxStackDepth = tiStatGetMaxStackDepth stats 640 | 641 | #if __CLH_EXERCISE_2__ >= 31 642 | #if __CLH_EXERCISE_2__ < 33 643 | findStackRoots stack = stack 644 | findDumpRoots dump = foldr (++) [] dump 645 | findGlobalRoots globals = aRange globals 646 | #endif 647 | 648 | #if __CLH_EXERCISE_2__ >= 32 649 | #if __CLH_EXERCISE_2__ < 35 650 | data Node 651 | = NAp Addr Addr 652 | | NSc Name [Name] CoreExpr 653 | | NNum Int 654 | | NInd Addr 655 | | NPrim Name Primitive 656 | | NData Int [Addr] 657 | | NMarked Node 658 | #endif 659 | 660 | gcHeapSize = 50 661 | 662 | #if __CLH_EXERCISE_2__ < 33 663 | markFrom heap addr 664 | = case node of 665 | NMarked _ -> heap 666 | NAp chAddr1 chAddr2 -> markFrom (markFrom markedHeap chAddr1) chAddr2 667 | NInd chAddr -> markFrom markedHeap chAddr 668 | NData _ chAddrs -> foldl markFrom markedHeap chAddrs 669 | _ -> markedHeap 670 | where 671 | markedHeap = statHUpdate heap addr (NMarked node) 672 | node = statHLookup heap addr 673 | #endif 674 | 675 | #if __CLH_EXERCISE_2__ < 35 676 | scanHeap heap = foldl freeUnmarkedAddr heap addrs 677 | where 678 | freeUnmarkedAddr h a = case statHLookup h a of 679 | NMarked n -> statHUpdate h a n 680 | _ -> statHFree h a 681 | 682 | addrs = statHAddresses heap 683 | 684 | showNode _ (NAp a1 a2) 685 | = iConcat [ iStr "NAp ", showAddrToSeq a1, iStr " ", showAddrToSeq a2 ] 686 | showNode _ (NSc scName argNames body) = iStr ("NSc " ++ scName) 687 | showNode _ (NNum n) = iStr "NNum " `iAppend` iNum n 688 | showNode heap (NInd a) 689 | = iConcat [ iStr "NInd (", showNode heap (statHLookup heap a), iStr ")" ] 690 | showNode heap (NPrim name _) 691 | = iConcat [ iStr "NPrim ", iStr name ] 692 | showNode heap (NData tag args) 693 | = iConcat [ iStr "NData ", iNum tag, iStr ", ", iInterleave (iStr " ") (map showFWAddr args) ] 694 | showNode heap (NMarked n) 695 | = iConcat [ iStr "NMarked (", showNode heap n, iStr ")" ] 696 | #endif 697 | 698 | #if __CLH_EXERCISE_2__ >= 33 699 | markFrom :: TiHeap -> Addr -> (TiHeap, Addr) 700 | 701 | markFromStack :: TiHeap -> TiStack -> (TiHeap, TiStack) 702 | markFromDump :: TiHeap -> TiDump -> (TiHeap, TiDump) 703 | markFromGlobals :: TiHeap -> TiGlobals -> (TiHeap, TiGlobals) 704 | 705 | #if __CLH_EXERCISE_2__ < 35 706 | markFrom heap addr 707 | = case node of 708 | NMarked _ -> (heap, addr) 709 | NAp chAddr1 chAddr2 -> 710 | let (markedHeap', chAddr1') = markFrom markedHeap chAddr1 711 | (markedHeap'', chAddr2') = markFrom markedHeap' chAddr2 712 | in 713 | (statHUpdate markedHeap'' addr (NMarked (NAp chAddr1' chAddr2')), addr) 714 | NInd chAddr -> markFrom heap chAddr 715 | NData tag chAddrs -> 716 | let (markedHeap', chAddrs') = mapAccumL markFrom markedHeap chAddrs 717 | in 718 | (statHUpdate markedHeap' addr (NMarked (NData tag chAddrs')), addr) 719 | _ -> (markedHeap, addr) 720 | where 721 | markedHeap = statHUpdate heap addr (NMarked node) 722 | node = statHLookup heap addr 723 | #endif 724 | 725 | markFromStack heap stack = mapAccumL markFrom heap stack 726 | markFromDump heap dump = mapAccumL markDumpPart heap dump 727 | where 728 | markDumpPart h as = mapAccumL markFrom h as 729 | markFromGlobals heap globals = mapAccumL markGlobal heap globals 730 | where 731 | markGlobal h (n, a) = 732 | let (h', a') = markFrom h a 733 | in 734 | (h', (n, a')) 735 | 736 | #if __CLH_EXERCISE_2__ < 36 737 | gc (output, stack, dump, heap, globals, stats) 738 | = (output, stack', dump', heap', globals', stats) 739 | where 740 | (globalGCHeap, globals') = markFromGlobals heap globals 741 | (dumpGCHeap, dump') = markFromDump globalGCHeap dump 742 | (stackGCHeap, stack') = markFromStack dumpGCHeap stack 743 | heap' = scanHeap stackGCHeap 744 | #endif 745 | 746 | #if __CLH_EXERCISE_2__ >= 35 747 | #if __CLH_EXERCISE_2__ < 36 748 | data Node 749 | = NAp Addr Addr 750 | | NSc Name [Name] CoreExpr 751 | | NNum Int 752 | | NInd Addr 753 | | NPrim Name Primitive 754 | | NData Int [Addr] 755 | | NMarked MarkState Node 756 | 757 | data MarkState 758 | = Done 759 | | Visits Int 760 | 761 | markFrom heap addr 762 | = markingAutomata addr statHNull heap 763 | 764 | markingAutomata :: Addr -> Addr -> TiHeap -> (TiHeap, Addr) 765 | markingAutomata f b h 766 | = case (fNode, statHIsNull b) of 767 | (NAp a1 a2, _) -> 768 | markingAutomata a1 f (updateF (NMarked (Visits 1) (NAp b a2))) 769 | (NInd a, _) -> 770 | markingAutomata a b h 771 | (NData _ [], _) -> 772 | markingAutomata f b (updateF (NMarked Done fNode)) 773 | (NData t (a : as), _) -> 774 | markingAutomata a f (updateF (NMarked (Visits 1) (NData t (b : as)))) 775 | (NMarked Done _, False) -> 776 | case bNode of 777 | NMarked (Visits v) (NData t as) -> 778 | let (f', b', ms', makeAs') = nextData v as 779 | in 780 | markingAutomata f' b' (updateB (NMarked ms' (NData t (makeAs' [])))) 781 | NMarked (Visits 1) (NAp b' a2) -> 782 | markingAutomata a2 b (updateB (NMarked (Visits 2) (NAp f b'))) 783 | NMarked (Visits 2) (NAp a1 b') -> 784 | markingAutomata b b' (updateB (NMarked Done (NAp a1 f))) 785 | (NMarked Done _, True) -> 786 | (h, f) 787 | _ -> 788 | markingAutomata f b (updateF (NMarked Done fNode)) 789 | where 790 | updateF = statHUpdate h f 791 | updateB = statHUpdate h b 792 | 793 | nextData v = foldl (makeNextData v) (statHNull, statHNull, Done, id) . zip [1..] 794 | makeNextData v (f', b', ms', fun') (n, a) 795 | | n == v = (b, a, ms', fun' . (f :)) 796 | | n == v + 1 = (a, b, Visits n, fun' . (b' :)) 797 | | otherwise = (f', b', ms', fun' . (a :)) 798 | 799 | fNode = statHLookup h f 800 | bNode = statHLookup h b 801 | 802 | scanHeap heap = foldl freeUnmarkedAddr heap addrs 803 | where 804 | freeUnmarkedAddr h a = case statHLookup h a of 805 | NMarked _ n -> statHUpdate h a n 806 | _ -> statHFree h a 807 | 808 | addrs = statHAddresses heap 809 | 810 | showNode _ (NAp a1 a2) 811 | = iConcat [ iStr "NAp ", showAddrToSeq a1, iStr " ", showAddrToSeq a2 ] 812 | showNode _ (NSc scName argNames body) = iStr ("NSc " ++ scName) 813 | showNode _ (NNum n) = iStr "NNum " `iAppend` iNum n 814 | showNode heap (NInd a) 815 | = iConcat [ iStr "NInd (", showNode heap (statHLookup heap a), iStr ")" ] 816 | showNode heap (NPrim name _) 817 | = iConcat [ iStr "NPrim ", iStr name ] 818 | showNode heap (NData tag args) 819 | = iConcat [ iStr "NData ", iNum tag, iStr ", ", iInterleave (iStr " ") (map showFWAddr args) ] 820 | showNode heap (NMarked Done n) 821 | = iConcat [ iStr "NMarked (", iStr "Done, ", showNode heap n, iStr ")" ] 822 | showNode heap (NMarked (Visits v) n) 823 | = iConcat [ iStr "NMarked (", iNum v, iStr ", ", showNode heap n, iStr ")" ] 824 | #else 825 | markFrom = undefined 826 | scanHeap = undefined 827 | #endif 828 | 829 | #if __CLH_EXERCISE_2__ >= 36 830 | data Node 831 | = NAp Addr Addr 832 | | NSc Name [Name] CoreExpr 833 | | NNum Int 834 | | NInd Addr 835 | | NPrim Name Primitive 836 | | NData Int [Addr] 837 | | NForward Addr 838 | 839 | evacuateStack :: TiHeap -> TiHeap -> TiStack -> (TiHeap, TiHeap, TiStack) 840 | evacuateDump :: TiHeap -> TiHeap -> TiDump -> (TiHeap, TiHeap, TiDump) 841 | evacuateGlobals :: TiHeap -> TiHeap -> TiGlobals -> (TiHeap, TiHeap, TiGlobals) 842 | 843 | scavengeHeap :: TiHeap -> TiHeap -> TiHeap 844 | 845 | evacuateStack fromHeap toHeap = joinTriple . mapAccumL evacuateFrom (fromHeap, toHeap) 846 | 847 | evacuateDump fromHeap toHeap = joinTriple . mapAccumL evacuateFroms (fromHeap, toHeap) 848 | 849 | evacuateGlobals fromHeap toHeap = joinTriple . mapAccumL evacuateEntry (fromHeap, toHeap) 850 | where 851 | evacuateEntry (f, t) (n, a) = second (\a' -> (n, a')) (evacuateFrom (f, t) a) 852 | 853 | evacuateFroms :: (TiHeap, TiHeap) -> [Addr] -> ((TiHeap, TiHeap), [Addr]) 854 | evacuateFroms = mapAccumL evacuateFrom 855 | 856 | evacuateFrom :: (TiHeap, TiHeap) -> Addr -> ((TiHeap, TiHeap), Addr) 857 | evacuateFrom (fromHeap, toHeap) addr = 858 | case node of 859 | NAp a1 a2 -> 860 | let ((fromHeap'', toHeap''), _) = evacuateFroms (fromHeap', toHeap') [a1, a2] 861 | in 862 | ((fromHeap'', toHeap''), addr') 863 | NInd a -> 864 | let ((fromHeap'', toHeap''), a') = evacuateFrom (fromHeap, toHeap) a 865 | in 866 | ((statHUpdate fromHeap'' addr (NForward a'), toHeap''), a') 867 | NData t as -> 868 | let ((fromHeap'', toHeap''), _) = evacuateFroms (fromHeap', toHeap') as 869 | in 870 | ((fromHeap'', toHeap''), addr') 871 | NForward a -> ((fromHeap, toHeap), a) 872 | _ -> ((fromHeap', toHeap'), addr') 873 | where 874 | node = statHLookup fromHeap addr 875 | (toHeap', addr') = statHAlloc toHeap node 876 | fromHeap' = statHUpdate fromHeap addr (NForward addr') 877 | 878 | scavengeHeap fromHeap toHeap = toHeap' 879 | where 880 | toHeap' = foldl (scavengeFrom fromHeap) toHeap (statHAddresses toHeap) 881 | 882 | scavengeFrom :: TiHeap -> TiHeap -> Addr -> TiHeap 883 | scavengeFrom fromHeap toHeap addr = 884 | case node of 885 | NAp a1 a2 -> 886 | let [a1', a2'] = getToAddrs [a1, a2] 887 | in 888 | statHUpdate toHeap addr (NAp a1' a2') 889 | NData t as -> 890 | let as' = getToAddrs as 891 | in 892 | statHUpdate toHeap addr (NData t as') 893 | _ -> toHeap 894 | where 895 | node = statHLookup toHeap addr 896 | getToAddrs = map getToAddr 897 | getToAddr = (\(NForward a) -> a) . statHLookup fromHeap 898 | 899 | breakTriple :: (a, b, c) -> ((a, b), c) 900 | breakTriple (a, b, c) = ((a, b), c) 901 | 902 | joinTriple :: ((a, b), c) -> (a, b, c) 903 | joinTriple ((a, b), c) = (a, b, c) 904 | 905 | gc state@(output, stack, dump, heap, globals, stats) 906 | = (output, stack', dump', heap', globals', stats) 907 | where 908 | (globalsFromHeap, globalsToHeap, globals') = evacuateGlobals heap statHInitial globals 909 | (dumpFromHeap, dumpToHeap, dump') = evacuateDump globalsFromHeap globalsToHeap dump 910 | (stackFromHeap, stackToHeap, stack') = evacuateStack dumpFromHeap dumpToHeap stack 911 | heap' = scavengeHeap stackFromHeap stackToHeap 912 | 913 | showNode _ (NAp a1 a2) 914 | = iConcat [ iStr "NAp ", showAddrToSeq a1, iStr " ", showAddrToSeq a2 ] 915 | showNode _ (NSc scName argNames body) = iStr ("NSc " ++ scName) 916 | showNode _ (NNum n) = iStr "NNum " `iAppend` iNum n 917 | showNode heap (NInd a) 918 | = iConcat [ iStr "NInd (", showNode heap (statHLookup heap a), iStr ")" ] 919 | showNode heap (NPrim name _) 920 | = iConcat [ iStr "NPrim ", iStr name ] 921 | showNode heap (NData tag args) 922 | = iConcat [ iStr "NData ", iNum tag, iStr ", ", iInterleave (iStr " ") (map showFWAddr args) ] 923 | showNode heap (NForward addr) 924 | = iConcat [ iStr "NForward ", showFWAddr addr ] 925 | #endif 926 | #endif 927 | #endif 928 | #else 929 | markFrom = undefined 930 | 931 | scanHeap = undefined 932 | #endif 933 | #else 934 | findStackRoots = undefined 935 | findDumpRoots = undefined 936 | findGlobalRoots = undefined 937 | #endif 938 | #endif 939 | #endif 940 | -------------------------------------------------------------------------------- /src/Language/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Language.Types where 3 | 4 | import Util 5 | 6 | data Expr a 7 | = EVar Name 8 | | ENum Int 9 | | EConstr Int Int 10 | | EAp (Expr a) (Expr a) 11 | | ELet 12 | IsRec 13 | (Assoc a (Expr a)) 14 | (Expr a) 15 | | ECase 16 | (Expr a) 17 | [Alter a] 18 | | ELam [a] (Expr a) 19 | deriving ( Show 20 | , Read 21 | , Eq 22 | ) 23 | type CoreExpr = Expr Name 24 | 25 | type Name = String 26 | 27 | type IsRec = Bool 28 | 29 | recursive, nonRecursive :: IsRec 30 | recursive = True 31 | nonRecursive = False 32 | 33 | bindersOf :: Assoc a b -> [a] 34 | bindersOf = aDomain 35 | rhssOf :: Assoc a b -> [b] 36 | rhssOf = aRange 37 | 38 | type Alter a = (Int, [a], Expr a) 39 | type CoreAlter = Alter Name 40 | 41 | isAExpr :: Expr a -> Bool 42 | isAExpr (EVar _) = True 43 | isAExpr (ENum _) = True 44 | isAExpr _ = False 45 | 46 | type Program a = [ScDefn a] 47 | type CoreProgram = Program Name 48 | 49 | type ScDefn a = (Name, [a], Expr a) 50 | type CoreScDefn = ScDefn Name 51 | 52 | #if __CLH_EXERCISE_6__ >= 1 53 | data AnnExpr' a b 54 | = AVar Name 55 | | ANum Int 56 | | AConstr Int Int 57 | | AAp (AnnExpr a b) (AnnExpr a b) 58 | | ALet 59 | IsRec 60 | (Assoc a (AnnExpr a b)) 61 | (AnnExpr a b) 62 | | ACase 63 | (AnnExpr a b) 64 | [AnnAlter a b] 65 | | ALam [a] (AnnExpr a b) 66 | deriving ( Show 67 | , Read 68 | , Eq 69 | ) 70 | type AnnExpr a b = (b, AnnExpr' a b) 71 | 72 | type AnnAlter a b = (Int, [a], AnnExpr a b) 73 | 74 | type AnnProgram a b = [AnnScDefn a b] 75 | 76 | type AnnScDefn a b = (Name, [a], AnnExpr a b) 77 | #endif 78 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | module Util 2 | ( hInitial 3 | , hAlloc 4 | , hUpdate 5 | , hFree 6 | , hLookup 7 | , hAddresses 8 | , hSize 9 | , hNull 10 | , hIsNull 11 | , showAddr 12 | , Heap 13 | , Addr 14 | 15 | , Assoc 16 | , aLookup 17 | , aDomain 18 | , aRange 19 | , aEmpty 20 | 21 | , getName 22 | , getNames 23 | , initialNameSupply 24 | , NameSupply 25 | 26 | , setFromList 27 | , setToList 28 | , setUnion 29 | , setIntersection 30 | , setSubtraction 31 | , setElementOf 32 | , setEmpty 33 | , setIsEmpty 34 | , setSingleton 35 | , setUnionList 36 | , Set 37 | 38 | , space 39 | ) 40 | where 41 | 42 | import Data.List 43 | 44 | -- | 45 | -- 'shownum','hd', 'tl' and 'zip2' are omitted sesince 46 | -- they are trivia in Haskell. 47 | 48 | hInitial :: Heap a 49 | hAlloc :: Heap a -> a -> (Heap a, Addr) 50 | hUpdate :: Heap a -> Addr -> a -> Heap a 51 | hFree :: Heap a -> Addr -> Heap a 52 | hLookup :: Heap a -> Addr -> a 53 | hAddresses :: Heap a -> [Addr] 54 | hSize :: Heap a -> Int 55 | hNull :: Addr 56 | hIsNull :: Addr -> Bool 57 | showAddr :: Addr -> String 58 | 59 | type Heap a = (Int, [Addr], Assoc Addr a) 60 | type Addr = Int 61 | 62 | hInitial = (0, [1..], []) 63 | hAlloc (size, next : free, cts) n = ((size + 1, free, (next, n) : cts), next) 64 | hUpdate (size, free, cts) addr a = (size, free, (addr, a) : remove cts addr) 65 | hFree (size, free, cts) addr = (size - 1, free, remove cts addr) 66 | hLookup (_, _, cts) addr = aLookup cts addr (error $ "can't find node" ++ showAddr addr ++ " in heap") 67 | hAddresses (_, _, cts) = [ addr | (addr, _) <- cts ] 68 | hSize (size, _, _) = size 69 | hNull = 0 70 | hIsNull = (== hNull) 71 | showAddr addr = "#" ++ show addr 72 | 73 | remove :: Assoc Addr a -> Addr -> Assoc Addr a 74 | remove ((addr', a) : cts) addr 75 | | addr == addr' = cts 76 | | otherwise = (addr', a) : remove cts addr 77 | remove [] addr = error $ "Attempt to update or free nonexistent address " ++ showAddr addr 78 | 79 | type Assoc a b = [(a, b)] 80 | 81 | aLookup :: (Eq a) => Assoc a b -> a -> b -> b 82 | aLookup ((key', val) : bs) key def 83 | | key == key' = val 84 | | otherwise = aLookup bs key def 85 | aLookup [] key def = def 86 | 87 | aDomain :: Assoc a b -> [a] 88 | aDomain alist = [ key | (key, _) <- alist ] 89 | 90 | aRange :: Assoc a b -> [b] 91 | aRange alist = [ val | (_, val) <- alist ] 92 | 93 | aEmpty :: Assoc a b 94 | aEmpty = [] 95 | 96 | getName :: NameSupply -> String -> (NameSupply, String) 97 | getNames :: NameSupply -> [String] -> (NameSupply, [String]) 98 | initialNameSupply :: NameSupply 99 | 100 | type NameSupply = Int 101 | 102 | initialNameSupply = 0 103 | getName nameSupply prefix = (nameSupply + 1, makeName prefix nameSupply) 104 | getNames nameSupply prefixes 105 | = (nameSupply + length prefixes, zipWith makeName prefixes [nameSupply..]) 106 | 107 | makeName prefix ns = prefix ++ "_" ++ show ns 108 | 109 | setFromList :: (Ord a) => [a] -> Set a 110 | setToList :: (Ord a) => Set a -> [a] 111 | setUnion :: (Ord a) => Set a -> Set a -> Set a 112 | setIntersection :: (Ord a) => Set a -> Set a -> Set a 113 | setSubtraction :: (Ord a) => Set a -> Set a -> Set a 114 | setElementOf :: (Ord a) => a -> Set a -> Bool 115 | setEmpty :: (Ord a) => Set a 116 | setIsEmpty :: (Ord a) => Set a -> Bool 117 | setSingleton :: (Ord a) => a -> Set a 118 | setUnionList :: (Ord a) => [Set a] -> Set a 119 | 120 | type Set a = [a] 121 | 122 | setEmpty = [] 123 | setIsEmpty = null 124 | setSingleton x = [x] 125 | setFromList = rmDup . sort 126 | where 127 | rmDup [] = [] 128 | rmDup [x] = [x] 129 | rmDup (x0 : x1: xs) 130 | | x0 == x1 = rmDup (x1 : xs) 131 | | otherwise = x0 : rmDup (x1 : xs) 132 | 133 | setToList xs = xs 134 | 135 | setUnion set1@(e1 : es1) set2@(e2 : es2) 136 | | e1 < e2 = e1 : setUnion es1 set2 137 | | e1 == e2 = e1 : setUnion es1 es2 138 | | e1 > e2 = e2 : setUnion set1 es2 139 | setUnion set1@(_ : _) [] = set1 140 | setUnion [] set2@(_ : _) = set2 141 | setUnion [] [] = [] 142 | 143 | setIntersection set1@(e1 : es1) set2@(e2 : es2) 144 | | e1 < e2 = setIntersection es1 set2 145 | | e1 == e2 = e1 : setIntersection es1 es2 146 | | e1 > e2 = setIntersection set1 es2 147 | setIntersection (_ : _) [] = [] 148 | setIntersection [] (_ : _) = [] 149 | setIntersection [] [] = [] 150 | 151 | setSubtraction set1@(e1 : es1) set2@(e2 : es2) 152 | | e1 < e2 = e1 : setSubtraction es1 set2 153 | | e1 == e2 = setSubtraction es1 es2 154 | | e1 > e2 = setSubtraction set1 es2 155 | setSubtraction set1@(_ : _) [] = set1 156 | setSubtraction [] (_ : _) = [] 157 | setSubtraction [] [] = [] 158 | 159 | setElementOf _ [] = False 160 | setElementOf x (y : ys) = x == y || (x > y && setElementOf x ys) 161 | 162 | setUnionList = foldl setUnion setEmpty 163 | 164 | -- | 165 | -- 'first','second', 'zipWith', 'foldll', 166 | -- 'mapAccuml' and 'sort' are omitted sesince 167 | -- they are trivia in Haskell. 168 | 169 | space :: Int -> String 170 | space indent = replicate indent ' ' 171 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.11 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | -------------------------------------------------------------------------------- /test/Fixtures/Examples.hs: -------------------------------------------------------------------------------- 1 | module Fixtures.Examples 2 | ( CoreExample 3 | , CoreExampleData 4 | , CoreExampleName 5 | , CoreExampleCode 6 | 7 | , readCoreExamples 8 | , getExampleName 9 | , getCode 10 | , getParsed 11 | ) 12 | where 13 | 14 | import Control.Arrow 15 | import Control.Monad 16 | import Data.List 17 | import Language.Types 18 | import System.Directory 19 | import System.FilePath 20 | import System.IO.Unsafe 21 | 22 | import Paths_core_lang_haskell 23 | 24 | type CoreExample = (CoreExampleName, CoreExampleData) 25 | type CoreExampleData = (CoreExampleCode, CoreProgram) 26 | type CoreExampleName = String 27 | type CoreExampleCode = String 28 | 29 | getExampleName :: CoreExample -> CoreExampleName 30 | getExampleName (name, _) = name 31 | 32 | getCode :: CoreExample -> CoreExampleCode 33 | getCode (_, (code, _)) = code 34 | 35 | getParsed :: CoreExample -> CoreProgram 36 | getParsed (_, (_, parsed)) = parsed 37 | 38 | readCoreExamples :: IO [CoreExample] 39 | readCoreExamples = do 40 | dir <- readCoreExampleDirectory 41 | fileNames <- listDirectory dir 42 | let names = sort . map dropExtension . filter isExampleFile $ fileNames 43 | paths = makeExamplePaths dir names 44 | forM (zip names paths) readCoreExample 45 | where 46 | readCoreExample = runKleisli . second $ Kleisli readFile *** readFileAsProgramKleisli 47 | readFileAsProgramKleisli = Kleisli readFile >>> arr read 48 | makeExamplePaths = map . makeExamplePath 49 | makeExamplePath dir = ((`addExtension` ".core") &&& (`addExtension` ".parse")) . combine dir 50 | 51 | readCoreExampleDirectory :: IO FilePath 52 | readCoreExampleDirectory = ( "examples") <$> getDataDir 53 | 54 | isExampleFile :: CoreExampleName -> Bool 55 | isExampleFile name = ".core" `isExtensionOf` name 56 | -------------------------------------------------------------------------------- /test/Language/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.ParserSpec 2 | ( main 3 | , spec 4 | ) 5 | where 6 | 7 | import Control.Exception 8 | import Control.Monad 9 | import Control.Monad.IO.Class 10 | import Fixtures.Examples 11 | import Language.Parser 12 | import Language.Types 13 | import Test.Hspec 14 | 15 | main :: IO () 16 | main = hspec spec 17 | 18 | {- HLint ignore spec "Redundant do" -} 19 | spec :: Spec 20 | spec = do 21 | describe "parse" $ do 22 | coreExamples <- runIO readCoreExamples 23 | forM_ coreExamples $ \example -> do 24 | let name = getExampleName example 25 | code = getCode example 26 | parsed = getParsed example 27 | describe ("with " ++ name) $ do 28 | it "A result of parsing should match with a predefined parsed" $ do 29 | parse code `shouldBe` parsed 30 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------