1 2 -- ==========================================================-- 3 -- === The Lambda-lifter ===-- 4 -- === LambdaLift5.hs ===-- 5 -- ==========================================================-- 6 7 module LambdaLift5 where 8 import BaseDefs 9 import Utils 10 import MyUtils 11 import Dependancy 12 13 import List(nub) -- 1.3 14 15 -- ==========================================================-- 16 -- First, put "split" lambda abstractions back together. 17 -- Largely decorative, but it seems like a sensible thing to do. 18 -- 19 llMergeLams :: CExprP Naam -> 20 CExprP Naam 21 22 llMergeLams (EVar v) = EVar v 23 llMergeLams (ENum n) = ENum n 24 llMergeLams (EConstr c) = EConstr c 25 llMergeLams (EAp e1 e2) = EAp (llMergeLams e1) (llMergeLams e2) 26 llMergeLams (ECase sw alts) 27 = ECase (llMergeLams sw) 28 [(n, (ps, llMergeLams rhs)) | (n, (ps, rhs)) <- alts] 29 llMergeLams (ELam vs1 (ELam vs2 e)) 30 = llMergeLams (ELam (vs1++vs2) e) 31 llMergeLams (ELam vs e) 32 = ELam vs (llMergeLams e) 33 llMergeLams (ELet rf defs e) 34 = ELet rf (map2nd llMergeLams defs) (llMergeLams e) 35 36 37 -- ==========================================================-- 38 -- Now give a name to all anonymous lambda abstractions. 39 -- As it happens, they all get the same name, but that's not 40 -- a problem: they get different names later on. 41 -- This pass has the effect of attaching all lambda terms 42 -- to a let binding, if they are not already so attached. 43 -- 44 llName :: CExprP Naam -> 45 CExprP Naam 46 47 llName (EVar v) = EVar v 48 llName (ENum n) = ENum n 49 llName (EConstr c) = EConstr c 50 llName (EAp e1 e2) = EAp (llName e1) (llName e2) 51 llName (ELam vs e) = ELet False [("_sc", ELam vs (llName e))] (EVar "_sc") 52 llName (ECase sw alts) 53 = ECase (llName sw) [(n, (ps, llName rhs)) | (n, (ps, rhs)) <- alts] 54 llName (ELet rf defs e) 55 = ELet rf (map fix defs) (llName e) 56 where 57 fix (n, ELam vs e) = (n, ELam vs (llName e)) 58 fix (n, non_lam_e) = (n, llName non_lam_e) 59 60 61 -- ==========================================================-- 62 -- Next, travel over the tree and attach a number to each 63 -- name, making them all unique. This implicitly defines the 64 -- scope bindings used. 65 -- 66 llUnique :: NameSupply -> 67 AList Naam Naam -> 68 CExprP Naam -> 69 (NameSupply, CExprP Naam) 70 71 llUnique ns dict (ENum n) = (ns, ENum n) 72 llUnique ns dict (EConstr c) = (ns, EConstr c) 73 llUnique ns dict (EAp e1 e2) 74 = let (ns_new1, e1_new) = llUnique ns dict e1 75 (ns_new2, e2_new) = llUnique ns_new1 dict e2 76 in (ns_new2, EAp e1_new e2_new) 77 78 llUnique ns dict (ECase sw alts) 79 = let (ns_new1, sw_new) = llUnique ns dict sw 80 (ns_new2, alts_new) = mapAccuml fixAlt ns_new1 alts 81 fixAlt ns (n, (ps, rhs)) 82 = let (new_ns, new_params) = utGetNames ns (llCheckUnique ps) 83 new_dict = zip ps new_params ++ dict 84 (final_ns, final_rhs) = llUnique new_ns new_dict rhs 85 in (final_ns, (n, (new_params, final_rhs))) 86 in (ns_new2, ECase sw_new alts_new) 87 88 llUnique ns dict (EVar v) 89 = case utLookup dict v of 90 Just v2 -> (ns, EVar v2) 91 Nothing -> myFail ("No such variable \"" ++ v ++ "\"") 92 93 llUnique ns dict (ELam vs e) 94 = let (new_ns, new_params) = utGetNames ns (llCheckUnique vs) 95 new_dict = zip vs new_params ++ dict 96 (final_ns, final_e) = llUnique new_ns new_dict e 97 in (final_ns, ELam new_params final_e) 98 99 llUnique ns dict (ELet rf defs e) 100 = let (new_ns2, new_defs) = mapAccuml fixDef new_ns1 defs 101 (final_ns, new_e) = llUnique new_ns2 dictAug e 102 hereNames = llCheckUnique (map first defs) 103 (new_ns1, hereBinds) = utGetNames ns (llCheckUnique hereNames) 104 dictAug = zip hereNames (map ('_':) hereBinds) ++ dict 105 dictForDefs = if rf then dictAug else dict 106 fixDef ns_loc (n, rhs) 107 = let (ns_loc_final, rhs_final) = llUnique ns_loc dictForDefs rhs 108 in (ns_loc_final, (utSureLookup dictAug "llUnique" n, rhs_final)) 109 in (final_ns, ELet rf new_defs new_e) 110 111 112 -- ==========================================================-- 113 -- Makes sure a set of names is unique. 114 -- 115 llCheckUnique :: [Naam] -> 116 [Naam] 117 118 llCheckUnique names 119 = let getdups [] = [] 120 getdups [x] = [] 121 getdups (x:y:xys) 122 | x == y = x:getdups (dropWhile (==x) xys) 123 | otherwise = getdups (y:xys) 124 dups = getdups (sort names) 125 in if null dups then names 126 else myFail ("Duplicate identifiers in the same scope:\n\t" ++ show dups) 127 128 129 -- ==========================================================-- 130 -- By now each variable is uniquely named, let bound vars have 131 -- been given a leading underscore, and, importantly, each lambda term 132 -- has an associated let-binding. Now do a free variables pass. 133 -- 134 llFreeVars :: CExprP Naam -> 135 AnnExpr Naam (Set Naam) 136 137 llFreeVars (ENum k) = (utSetEmpty, ANum k) 138 139 llFreeVars (EVar v) = (utSetSingleton v, AVar v) 140 141 llFreeVars (EConstr c) = (utSetEmpty, AConstr c) 142 143 llFreeVars (EAp e1 e2) 144 = let a_e1@(f_e1, _) = llFreeVars e1 145 a_e2@(f_e2, _) = llFreeVars e2 146 in (utSetUnion f_e1 f_e2, AAp a_e1 a_e2) 147 148 llFreeVars (ELam args body) 149 = let body_a@(body_f, _) = llFreeVars body 150 in (utSetSubtraction body_f (utSetFromList args), 151 ALam args body_a) 152 153 llFreeVars (ELet isRec defns body) 154 = let (binders, values) = unzip2 defns 155 binderSet = utSetFromList binders 156 values' = map llFreeVars values 157 defns' = zip binders values' 158 freeInValues = utSetUnionList [free | (free,_) <- values'] 159 defnsFree 160 | isRec = utSetSubtraction freeInValues binderSet 161 | otherwise = freeInValues 162 body' = llFreeVars body 163 bodyFree = utSetSubtraction (first body') binderSet 164 in (utSetUnion defnsFree bodyFree, ALet isRec defns' body') 165 166 llFreeVars (ECase e alts) 167 = let (eFree,_) = e' 168 e' = llFreeVars e 169 alts' = [(con,(args,llFreeVars e)) | (con,(args,e)) <- alts] 170 free = utSetUnionList (map f alts') 171 f (con,(args,(free,exp))) = 172 utSetSubtraction free (utSetFromList args) 173 in (utSetUnion eFree free, ACase e' alts') 174 175 176 -- ==========================================================-- 177 -- Extract the set equations. 178 -- 179 llEqns :: AnnExpr Naam (Set Naam) -> 180 [Eqn] 181 182 llEqns (_, AVar _) = [] 183 llEqns (_, ANum _) = [] 184 llEqns (_, AConstr _) = [] 185 llEqns (_, AAp a1 a2) = llEqns a1 ++ llEqns a2 186 llEqns (_, ALam _ e) = llEqns e 187 188 llEqns (_, ACase sw alts) 189 = llEqns sw ++ concat (map (llEqns.second.second) alts) 190 191 llEqns (_, ALet rf defs body) 192 = let binders = [n | (n, rhs) <- defs] 193 eqnsHere = [case llSplitSet fv of (facc, vacc) -> EqnNVC n vacc facc 194 | (n, (fv, rhsa)) <- defs] 195 innerEqns = concat [llEqns rhs | (n, rhs@(fv, rhsa)) <- defs] 196 nextEqns = llEqns body 197 in eqnsHere ++ innerEqns ++ nextEqns 198 199 200 -- ==========================================================-- 201 -- Now we use the information from the previous pass to 202 -- fix up usages of functions. 203 -- 204 llAddParams :: AList Naam (Set Naam) -> 205 AnnExpr Naam (Set Naam) -> 206 CExprP Naam 207 208 llAddParams env (_, ANum n) = ENum n 209 210 llAddParams env (_, AConstr c) = EConstr c 211 212 llAddParams env (_, AVar v) 213 = mkApChain vParams 214 where 215 vParams = utLookup env v 216 mkApChain (Just vs) = foldl EAp (EVar v) (map EVar (utSetToList vs)) 217 mkApChain Nothing = EVar v 218 219 llAddParams env (_, AAp e1 e2) 220 = EAp (llAddParams env e1) (llAddParams env e2) 221 222 llAddParams env (_, ALam args body) 223 = ELam args (llAddParams env body) 224 225 llAddParams env (_, ACase sw alts) 226 = ECase (llAddParams env sw) (map f alts) 227 where 228 f (naam, (params, body)) = (naam, (params, llAddParams env body)) 229 230 llAddParams env (_, ALet rFlag defs body) 231 = ELet rFlag (map fixDef defs) fixedBody 232 where 233 fixedBody = llAddParams env body 234 fixDef (n, (df, (ALam vs rhs))) 235 = let new_params = utSetToList (utSureLookup env "llAddParams1" n) 236 in (n, ELam (new_params++vs) (llAddParams env rhs)) 237 fixDef (n, (df, non_lambda_rhs)) 238 = let new_params = utSetToList (utSureLookup env "llAddParams2" n) 239 in (n, ELam new_params (llAddParams env (df, non_lambda_rhs))) 240 241 242 -- ==========================================================-- 243 -- The only thing that remains to be done is to flatten 244 -- out the program, by lifting out all the let (and hence lambda) 245 -- bindings to the top level. 246 -- 247 llFlatten :: CExprP Naam -> 248 (AList Naam (CExprP Naam), CExprP Naam) 249 250 llFlatten (EVar v) = ([], EVar v) 251 252 llFlatten (ENum n) = ([], ENum n) 253 254 llFlatten (EConstr c) = ([], EConstr c) 255 256 llFlatten (EAp e1 e2) 257 = (e1b ++ e2b, EAp e1f e2f) 258 where 259 (e1b, e1f) = llFlatten e1 260 (e2b, e2f) = llFlatten e2 261 262 llFlatten (ELam ps e1) 263 = (e1b, ELam ps e1f) 264 where 265 (e1b, e1f) = llFlatten e1 266 267 llFlatten (ECase sw alts) 268 = (swb ++ concat altsb, ECase swf altsf) 269 where 270 (swb, swf) = llFlatten sw 271 272 altsFixed = map fixAlt alts 273 fixAlt (name, (pars, rhs)) = (name, (pars, llFlatten rhs)) 274 275 altsf = map getAltsf altsFixed 276 getAltsf (name, (pars, (rhsb, rhsf))) = (name, (pars, rhsf)) 277 278 altsb = map getAltsb altsFixed 279 getAltsb (name, (pars, (rhsb, rhsf))) = rhsb 280 281 llFlatten (ELet rf dl rhs) 282 = (dlFlattened ++ rhsb, rhsf) 283 where 284 (rhsb, rhsf) = llFlatten rhs 285 286 dlFixed = map fixDef dl 287 fixDef (name, rhs) = (name, llFlatten rhs) 288 289 dlFlattened = dsHere ++ concat dsInside 290 dsHere = map here dlFixed 291 here (name, (inDs, frhs)) = (name, frhs) 292 dsInside = map inside dlFixed 293 inside (name, (inDs, frhs)) = inDs 294 295 296 -- ==========================================================-- 297 -- The transformed program is now correct, but hard to read 298 -- because all variables have a number on. This function 299 -- detects non-contentious variable names and deletes 300 -- the number, wherever possible. Also fixes up the 301 -- free-variable list appropriately. 302 -- 303 llPretty :: (AList Naam (CExprP Naam), AList Naam [Naam]) -> 304 (AList Naam (CExprP Naam), AList Naam [Naam]) 305 306 llPretty (scDefs, scFrees) 307 = let ------------------------------------------------- 308 -- scTable tells how to rename supercombinator -- 309 -- names only. Use to fix all SC names. -- 310 ------------------------------------------------- 311 scDefNames = map first scDefs 312 scTable = getContentious scDefNames 313 (scDefs1, scFrees1) 314 = ( [(prettyScName scTable n, 315 llMapCoreTree (prettyScName scTable) cexp) 316 | (n, cexp) <- scDefs], 317 map1st (prettyScName scTable) scFrees) 318 319 ---------------------------------------------- 320 -- Now for each supercombinator, fix up its -- 321 -- lambda-bound variables individually -- 322 ---------------------------------------------- 323 lamTableTable = map makeLamTable scDefs1 324 makeLamTable (n, ELam vs _) = getContentious vs 325 makeLamTable (n, non_lam_s) = [] 326 scFrees2 = myZipWith2 fixParams scFrees1 lamTableTable 327 fixParams (n, ps) contentious 328 = (n, map (prettyVarName contentious) ps) 329 scDefs2 = myZipWith2 fixDef scDefs1 lamTableTable 330 fixDef (n, cexp) contentious 331 = (n, llMapCoreTree (prettyVarName contentious) cexp) 332 333 334 getContentious names 335 = let sortedNames = sort names 336 gc [] = [] 337 gc [x] = [] 338 gc (x:y:xys) 339 | rootName x == rootName y = x:y:gc (y:xys) 340 | otherwise = gc (y:xys) 341 contentions = nub (gc sortedNames) 342 in contentions 343 344 prettyScName contentions n 345 | head n == '_' && n `notElem` contentions = rootName n 346 | otherwise = n 347 348 prettyVarName contentions n 349 | head n /= '_' && n `notElem` contentions = rootName n 350 | otherwise = n 351 352 rootName = takeWhile (/= ')') 353 354 in 355 (scDefs2, scFrees2) 356 357 358 -- ==========================================================-- 359 -- 360 llSplitSet :: Set Naam -> (Set Naam, Set Naam) 361 362 llSplitSet list 363 = let split (facc, vacc) n 364 = if head n == '_' then (n:facc, vacc) else (facc, n:vacc) 365 in case foldl split ([],[]) (utSetToList list) of 366 (fs, vs) -> (utSetFromList fs, utSetFromList vs) 367 368 369 -- ==========================================================-- 370 -- 371 llZapBuiltins :: [Naam] -> Eqn -> Eqn 372 373 llZapBuiltins builtins (EqnNVC n v c) 374 = EqnNVC n v (utSetFromList (filter (`notElem` builtins) (utSetToList c))) 375 376 377 -- ==========================================================-- 378 -- 379 llSolveIteratively :: [Eqn] -> AList Naam (Set Naam) 380 381 llSolveIteratively eqns 382 = loop eqns initSets 383 where 384 initSets = [(n, utSetEmpty) | EqnNVC n v c <- eqns] 385 loop eqns aSet 386 = let newSet = map (sub_eqn aSet) eqns 387 in if newSet == aSet then newSet else loop eqns newSet 388 sub_eqn subst (EqnNVC n v c) 389 = let allVars = utSetToList v ++ utSetToList c 390 allSub = utSetUnionList (map sub allVars) 391 sub var = utLookupDef subst var (utSetSingleton var) 392 in case llSplitSet allSub of (facc, vacc) -> (n, vacc) 393 394 395 -- ==========================================================-- 396 -- Map a function over a core tree. 397 -- *** Haskell-B 9972 insists on restricted signature, why? *** 398 -- 399 llMapCoreTree :: (Naam -> Naam) -> 400 CExprP Naam -> 401 CExprP Naam 402 403 llMapCoreTree f (EVar v) = EVar (f v) 404 llMapCoreTree f (ENum n) = ENum n 405 llMapCoreTree f (EConstr c) = EConstr c 406 llMapCoreTree f (ELam vs e) = ELam (map f vs) (llMapCoreTree f e) 407 llMapCoreTree f (EAp e1 e2) = EAp (llMapCoreTree f e1) (llMapCoreTree f e2) 408 llMapCoreTree f (ELet rf dl e) 409 = ELet rf [(f n, llMapCoreTree f rhs) | (n, rhs) <- dl] (llMapCoreTree f e) 410 llMapCoreTree f (ECase sw alts) 411 = ECase (llMapCoreTree f sw) 412 [(cn, (map f ps, llMapCoreTree f rhs)) | (cn, (ps, rhs)) <- alts] 413 414 415 -- ==========================================================-- 416 -- 417 llMain :: [Naam] -> 418 CExprP Naam -> 419 Bool -> 420 (CExprP Naam, AList Naam [Naam]) 421 422 llMain builtInNames expr doPretty = 423 let fvAnnoTree 424 = (llFreeVars . 425 second . 426 llUnique 0 initialRenamer . 427 llName . 428 llMergeLams . 429 deDependancy) expr 430 431 builtInFns = filter ((=='_').head) builtInNames 432 initFreeEnv = [(n, utSetEmpty) | n <- builtInNames] 433 initialRenamer = map (\n -> (tail n, n)) builtInFns 434 eqns = llEqns fvAnnoTree 435 eqns_with_builtins_zapped = map (llZapBuiltins builtInFns) eqns 436 eqns_solved = llSolveIteratively eqns_with_builtins_zapped 437 438 (scDefs, mainE) = llFlatten (llAddParams eqns_solved fvAnnoTree) 439 (prettyScDefs, prettyNewParams) 440 = if doPretty then llPretty (scDefs, scParams) else (scDefs, scParams) 441 scParams = map2nd utSetToList eqns_solved 442 exprReconstituted = ELet True prettyScDefs mainE 443 exprDepended = deDependancy exprReconstituted 444 in (exprDepended, prettyNewParams) 445 446 447 -- ==========================================================-- 448 -- === end LambdaLift5.hs ===-- 449 -- ==========================================================--