mutrec.sire (8655B)
1 ; Copyright 2023 The Plunder Authors 2 ; Use of this source code is governed by a BSD-style license that can be 3 ; found in the LICENSE file. 4 5 #### mutrec <- w64 6 7 ;;;; Mutually Recursive Functions 8 ;;;; ============================ 9 ;;;; 10 ;;;; Example Input: 11 ;;;; 12 ;;;; = (foo x) 13 ;;;; # mutrec %even_odd (even 9) 14 ;;;; * (even x) 15 ;;;; | ifNot x TRUE (odd dec-x) 16 ;;;; * (odd x) 17 ;;;; | ifNot x FALSE (even dec-x) 18 ;;;; 19 ;;;; Example Output: 20 ;;;; 21 ;;;; = (foo x) 22 ;;;; #@ _core1 23 ;;;; #? (_core1 _tag2 _g3) 24 ;;;; #@ even (x #& _core1 0 x) 25 ;;;; #@ odd (x #& _core1 1 x) 26 ;;;; #| switch _tag2 0 27 ;;;; #| **v2 28 ;;;; #@ n _g3 29 ;;;; | ifNot n TRUE (**odd dec-n) 30 ;;;; #@ m _g3 31 ;;;; | ifNot m FALSE (**even dec-m) 32 ;;;; #@ even (n & _core1 0 n) 33 ;;;; #@ odd (m & _core1 1 m) 34 ;;;; (**even x) 35 36 37 ;;; Imports ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 39 :| sire 40 :| sire_21_switch [unrollSlip2Rune unrollSlip2Tis] 41 42 43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 44 45 = (readCoreBody rune readExp rex err ok) 46 : clauses 47 < ^ unrollSlip2Rune rune rex _ err 48 ? (nonMatchingTail x err ret) 49 | err x {Not a core arm} 50 ^ rowTraverse _ clauses ok 51 & (sigBody ret) 52 @ [sigRex bodyRex] sigBody 53 : sym mark binds < readDestroyer sigRex err 54 : body < readExp bodyRex err 55 | if mark | err sigRex {can't inline mutually-recursive functions} 56 | ret [sym binds body] 57 58 =?= [[%f [[%v %x]] 'x] [%g [[%v %y]] '0]] 59 | readCoreBody {=} readRex '((f x = x)(g y = 0)) v2 id 60 61 =?= [[%f [[%r [[%v %x] [%v %y]]]] 'x]] 62 | readCoreBody {=} readRex '((f [x y] = x)) v2 id 63 64 =?= ['(*) {Not a core arm}] 65 | readCoreBody {=} readRex '((f x = x)(g y = 0)(*)) v2 id 66 67 =?= ['(= f) {= node expects two parameters}] 68 | readCoreBody {=} readRex '((= f|x x)(= f)) v2 id 69 70 =?= ['(**f x) {can't inline mutually-recursive functions}] 71 | readCoreBody {=} readRex '((**f x = x)(g y = 0)) v2 id 72 73 = (readMutRecExp readExp rex err ok) 74 : _ coreTag letBody coreBody 75 < ^ rexParseKids rex _ err 76 | (readRex, readAtomLit, readExp, readCoreBody {*} readExp) 77 | ok coreTag letBody coreBody 78 79 = (genCoreBody arms st ok) 80 ^ rowTraverseState st _ arms ok 81 & (st [sym binds body] ret) 82 | trk #[=sym =binds =body] 83 : st sig bod < makeDestroyer st binds body 84 | ret st [sym sig bod] 85 86 =?= ++ [5] 87 ++ ++ [%f [%x] 'x] 88 ++ [%g [%y] '0] 89 ^ genCoreBody _ [5] v2 90 | [[%f [[%v %x]] 'x] [%g [[%v %y]] '0]] 91 92 =?= ++ [7] 93 ++ ++ ++ {f} 94 ++ [{_g5}] 95 ++ ` #@ _g6 _g5 96 #@ x (#| $$(idx 0) _g6) 97 #@ y (#| $$(idx 1) _g6) 98 x 99 ^ genCoreBody _ [5] v2 100 | [[%f [[%r [[%v %x] [%v %y]]]] 'x]] 101 102 ; TODO Move this to `17-exp.sire` 103 = (taggedLamE nam tag args body) 104 @ sig (NEST {|} (rowCons (varE nam) args) 0) 105 | OPEN {#?} [(litE tag) sig] body 106 107 =?= (taggedLamE %f 2 ['x 'y 'z] 'x) 108 ' #? 2 (f x y z) 109 x 110 111 = (matchE x wildExp patExps) 112 | OPEN {#|} 113 ++ cnsE switch 114 ++ appE (cnsE (idx 0), x) 115 ++ wildExp 116 | bowE patExps 117 118 =?= (matchE '[0 1 2] '0 ['1 '2 '3]) 119 ` 120 #| $$switch (#| $$(idx 0) [0 1 2]) 0 121 #| $$(cow 3) 3 2 1 122 123 (maxRow x)=(foldl max (idx 0 x) x) 124 125 =?= 3 | maxRow [0 3 2] 126 =?= 4 | maxRow [0 3 4] 127 =?= 5 | maxRow [5 3 4] 128 =?= 0 | maxRow [] 129 130 = (genMutRecE st coreTag letBody coreBody ok) 131 ; 132 : st coreNam < generateTempName {core} st 133 : st sigExpPairs < genCoreBody coreBody st 134 ; 135 @ arms | listZip listEnumFrom-0 listFromRow-sigExpPairs 136 @ maxArgs 137 | maxRow 138 : [_ [_ args _]] < foreach (listToRow arms) 139 | len args 140 @ (bindArms body arms) 141 | listCase arms body 142 & (item rest) 143 @ [key arm] item 144 @ [fun args _] arm 145 @ extras (sub maxArgs | len args) 146 | letE fun 147 | inlinedLamE fun args 148 | appE 149 | weld (varE coreNam, cnsE key) 150 | weld (map varE args) 151 | rep (cnsE 0) extras 152 | bindArms body rest 153 : st coreArgs 154 < ^ rowTraverseState st _ (rep 0 maxArgs) 155 & (st item pure) 156 : st varExp < generateVarE {arg} st 157 | pure st varExp 158 : st tagArgExp < generateVarE {tag} st 159 @ coreArgs 160 | rowCons tagArgExp coreArgs 161 @ branches 162 : foo < foreach (listToRow arms) 163 @ [key [fun args body]] foo 164 ^ listFoldr _ body 165 | listDrop 1 | listIndexed | CONS fun | listFromRow args 166 & ([ix var] rest) 167 | letE var (idx ix coreArgs) rest 168 @ coreBody 169 | OPEN {#|} (cnsE switch, tagArgExp, cnsE 0) 170 | bowE branches 171 | ok st 172 | letE coreNam 173 | taggedLamE coreNam coreTag coreArgs 174 | bindArms coreBody arms 175 | bindArms letBody arms 176 177 = ({#mutrec} st rex err ok) 178 : coreTag letBody coreBody < readMutRecExp readRex rex err 179 : st rex < genMutRecE st coreTag letBody coreBody 180 | ok st rex 181 182 ; =?= 1 183 ; @ e 184 ; ' 185 ; # mutrec %loop (**loop start) 186 ; * (loop xx) 187 ; | ifNot xx 0 (**loop 0) 188 ; (.{#mutrec} 3 3 3 e v2 v4) 189 190 191 ; =?= 1 192 ; @ e 193 ; ' (#mutrec %loop (f 3) (f x = x)(g a e = g a e)) 194 ; (.{#mutrec} 3 3 3 e v2 v4) 195 196 = (foo x) 197 # mutrec %even_odd 198 (and (even x 8) (odd x)) 199 * (even x y) 200 | ifNot x TRUE (odd dec-x) 201 * (odd x) 202 | ifNot x FALSE (even dec-x 9) 203 204 = (looper start) 205 # mutrec %loop (loop start) 206 * (loop xx) 207 | ifNot xx 0 (loop 0) 208 209 = loopFun 210 ? (looper start) 211 ^ _ 0 start 212 ? (loop b x) 213 | switch b 0 214 ++ ifNot x 0 (loop 0 0) 215 216 =?= (car looper) 4 217 =?= (cdr looper) loopFun 218 =?= (pinItem looper) loopFun 219 =?= looper (PIN loopFun) 220 221 = [even odd] 222 # mutrec %even_odd [even odd] 223 * (even x) 224 | ifNot x TRUE (**odd dec-x) 225 * (odd x) 226 | ifNot x FALSE (**even dec-x) 227 228 !! even 0 229 !! even 2 230 !! even 20 231 !! odd 1 232 !! odd 3 233 !! odd 21 234 235 236 ;;; #mutual ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 237 238 = ({#mutual} st rex err ok) 239 : _ coreSymbol sigRex < rexParseKids rex [readRex readRex readRex] err 240 : arms < readCoreBody {=} readRex sigRex err 241 : st sigExpPairs < genCoreBody arms st 242 : coreName < readSymbol coreSymbol err 243 : st tagIdn < generateVarE {tag} st 244 @ 245 = coreIdn | varE coreName 246 = arms | listZip listEnumFrom-0 listFromRow-sigExpPairs 247 = maxArgs | maxRow 248 : [_ [fun args _]] < foreach (listToRow arms) 249 | len args 250 @ 251 (bindArms body arms) 252 | listCase arms body 253 & (item rest) 254 @ key,arm item 255 @ [fun args _] arm 256 @ extras (sub maxArgs | len args) 257 | letE fun 258 | inlinedLamE fun args 259 | appE 260 | weld (coreIdn, cnsE key) 261 | weld (map varE args) 262 | gen extras (const | cnsE 0) 263 | bindArms body rest 264 : st coreArgIdns 265 < ^ rowTraverseState st _ (gen maxArgs | const 0) 266 & (st _item pure) 267 : st idn < (generateVarE {arg} st) 268 | pure st idn 269 : st armDefuns 270 ; TODO: This does not actually need to traverse with state, 271 ; we never change anything. 272 < ^ listTraverseState st _ arms 273 & (st [key [armName argNames exp]] pure) 274 @ 275 = armIdn | varE armName 276 = armArgIdns | map varE argNames 277 = numArgs | len armArgIdns 278 = extraArgs | sub maxArgs numArgs 279 | pure st 280 | OPEN {#=} 281 ++ NEST {|} (rowCons armIdn armArgIdns) 0 282 ++ | appE 283 | weld (coreIdn, cnsE key) 284 | weld armArgIdns 285 | rep cnsE-0 extraArgs 286 | 0 287 @ 288 = coreSig 289 | rowCons tagIdn coreArgIdns 290 = branches 291 : foo < foreach (listToRow arms) 292 @ [key [branchArm branchArgs body]] foo 293 ^ listFoldr _ body 294 | listDrop 1 295 | listIndexed 296 | CONS branchArm 297 | listFromRow branchArgs 298 & ([ix var] rest) 299 | letE var (idx ix coreSig) rest 300 = coreBody 301 | OPEN {#|} (cnsE switch, tagIdn, cnsE 0) 302 | bowE branches 303 | ok st 304 | OPEN {#=} 305 ++ NEST {|} (rowCons coreIdn coreSig) 0 306 ++ bindArms coreBody arms 307 | bloodline armDefuns 308 309 # mutual even_odd 310 = (even x) 311 | ifNot x TRUE (**odd dec-x) 312 = (odd x) 313 | ifNot x FALSE (**even dec-x) 314 315 !! even 0 316 !! even 2 317 !! even 20 318 !! odd 1 319 !! odd 3 320 !! odd 21 321 322 ; Inspect the output of this by hand, lgtm. 323 # mutual foo_bar 324 = (foo [x !y]) 325 | add x x 326 = (bar x) 327 | foo [x x] 328 329 330 ;;; Exports ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 331 332 ^-^ 333 ^-^ unrollSlip2Tis 334 ^-^ readSignature 335 ^-^ bloodline 336 ^-^ 337 ^-^ readMutRecExp genMutRecE 338 ^-^ 339 ^-^ {#mutual} 340 ^-^ {#mutrec} 341 ^-^