-- ==========================================================-- -- === The Lambda-lifter ===-- -- === LambdaLift5.hs ===-- -- ==========================================================-- module LambdaLift5 where import BaseDefs import Utils import MyUtils import Dependancy import List(nub) -- 1.3 -- ==========================================================-- -- First, put "split" lambda abstractions back together. -- Largely decorative, but it seems like a sensible thing to do. -- llMergeLams :: CExprP Naam -> CExprP Naam llMergeLams (EVar v) = EVar v llMergeLams (ENum n) = ENum n llMergeLams (EConstr c) = EConstr c llMergeLams (EAp e1 e2) = EAp (llMergeLams e1) (llMergeLams e2) llMergeLams (ECase sw alts) = ECase (llMergeLams sw) [(n, (ps, llMergeLams rhs)) | (n, (ps, rhs)) <- alts] llMergeLams (ELam vs1 (ELam vs2 e)) = llMergeLams (ELam (vs1++vs2) e) llMergeLams (ELam vs e) = ELam vs (llMergeLams e) llMergeLams (ELet rf defs e) = ELet rf (map2nd llMergeLams defs) (llMergeLams e) -- ==========================================================-- -- Now give a name to all anonymous lambda abstractions. -- As it happens, they all get the same name, but that's not -- a problem: they get different names later on. -- This pass has the effect of attaching all lambda terms -- to a let binding, if they are not already so attached. -- llName :: CExprP Naam -> CExprP Naam llName (EVar v) = EVar v llName (ENum n) = ENum n llName (EConstr c) = EConstr c llName (EAp e1 e2) = EAp (llName e1) (llName e2) llName (ELam vs e) = ELet False [("_sc", ELam vs (llName e))] (EVar "_sc") llName (ECase sw alts) = ECase (llName sw) [(n, (ps, llName rhs)) | (n, (ps, rhs)) <- alts] llName (ELet rf defs e) = ELet rf (map fix defs) (llName e) where fix (n, ELam vs e) = (n, ELam vs (llName e)) fix (n, non_lam_e) = (n, llName non_lam_e) -- ==========================================================-- -- Next, travel over the tree and attach a number to each -- name, making them all unique. This implicitly defines the -- scope bindings used. -- llUnique :: NameSupply -> AList Naam Naam -> CExprP Naam -> (NameSupply, CExprP Naam) llUnique ns dict (ENum n) = (ns, ENum n) llUnique ns dict (EConstr c) = (ns, EConstr c) llUnique ns dict (EAp e1 e2) = let (ns_new1, e1_new) = llUnique ns dict e1 (ns_new2, e2_new) = llUnique ns_new1 dict e2 in (ns_new2, EAp e1_new e2_new) llUnique ns dict (ECase sw alts) = let (ns_new1, sw_new) = llUnique ns dict sw (ns_new2, alts_new) = mapAccuml fixAlt ns_new1 alts fixAlt ns (n, (ps, rhs)) = let (new_ns, new_params) = utGetNames ns (llCheckUnique ps) new_dict = zip ps new_params ++ dict (final_ns, final_rhs) = llUnique new_ns new_dict rhs in (final_ns, (n, (new_params, final_rhs))) in (ns_new2, ECase sw_new alts_new) llUnique ns dict (EVar v) = case utLookup dict v of Just v2 -> (ns, EVar v2) Nothing -> myFail ("No such variable \"" ++ v ++ "\"") llUnique ns dict (ELam vs e) = let (new_ns, new_params) = utGetNames ns (llCheckUnique vs) new_dict = zip vs new_params ++ dict (final_ns, final_e) = llUnique new_ns new_dict e in (final_ns, ELam new_params final_e) llUnique ns dict (ELet rf defs e) = let (new_ns2, new_defs) = mapAccuml fixDef new_ns1 defs (final_ns, new_e) = llUnique new_ns2 dictAug e hereNames = llCheckUnique (map first defs) (new_ns1, hereBinds) = utGetNames ns (llCheckUnique hereNames) dictAug = zip hereNames (map ('_':) hereBinds) ++ dict dictForDefs = if rf then dictAug else dict fixDef ns_loc (n, rhs) = let (ns_loc_final, rhs_final) = llUnique ns_loc dictForDefs rhs in (ns_loc_final, (utSureLookup dictAug "llUnique" n, rhs_final)) in (final_ns, ELet rf new_defs new_e) -- ==========================================================-- -- Makes sure a set of names is unique. -- llCheckUnique :: [Naam] -> [Naam] llCheckUnique names = let getdups [] = [] getdups [x] = [] getdups (x:y:xys) | x == y = x:getdups (dropWhile (==x) xys) | otherwise = getdups (y:xys) dups = getdups (sort names) in if null dups then names else myFail ("Duplicate identifiers in the same scope:\n\t" ++ show dups) -- ==========================================================-- -- By now each variable is uniquely named, let bound vars have -- been given a leading underscore, and, importantly, each lambda term -- has an associated let-binding. Now do a free variables pass. -- llFreeVars :: CExprP Naam -> AnnExpr Naam (Set Naam) llFreeVars (ENum k) = (utSetEmpty, ANum k) llFreeVars (EVar v) = (utSetSingleton v, AVar v) llFreeVars (EConstr c) = (utSetEmpty, AConstr c) llFreeVars (EAp e1 e2) = let a_e1@(f_e1, _) = llFreeVars e1 a_e2@(f_e2, _) = llFreeVars e2 in (utSetUnion f_e1 f_e2, AAp a_e1 a_e2) llFreeVars (ELam args body) = let body_a@(body_f, _) = llFreeVars body in (utSetSubtraction body_f (utSetFromList args), ALam args body_a) llFreeVars (ELet isRec defns body) = let (binders, values) = unzip2 defns binderSet = utSetFromList binders values' = map llFreeVars values defns' = zip binders values' freeInValues = utSetUnionList [free | (free,_) <- values'] defnsFree | isRec = utSetSubtraction freeInValues binderSet | otherwise = freeInValues body' = llFreeVars body bodyFree = utSetSubtraction (first body') binderSet in (utSetUnion defnsFree bodyFree, ALet isRec defns' body') llFreeVars (ECase e alts) = let (eFree,_) = e' e' = llFreeVars e alts' = [(con,(args,llFreeVars e)) | (con,(args,e)) <- alts] free = utSetUnionList (map f alts') f (con,(args,(free,exp))) = utSetSubtraction free (utSetFromList args) in (utSetUnion eFree free, ACase e' alts') -- ==========================================================-- -- Extract the set equations. -- llEqns :: AnnExpr Naam (Set Naam) -> [Eqn] llEqns (_, AVar _) = [] llEqns (_, ANum _) = [] llEqns (_, AConstr _) = [] llEqns (_, AAp a1 a2) = llEqns a1 ++ llEqns a2 llEqns (_, ALam _ e) = llEqns e llEqns (_, ACase sw alts) = llEqns sw ++ concat (map (llEqns.second.second) alts) llEqns (_, ALet rf defs body) = let binders = [n | (n, rhs) <- defs] eqnsHere = [case llSplitSet fv of (facc, vacc) -> EqnNVC n vacc facc | (n, (fv, rhsa)) <- defs] innerEqns = concat [llEqns rhs | (n, rhs@(fv, rhsa)) <- defs] nextEqns = llEqns body in eqnsHere ++ innerEqns ++ nextEqns -- ==========================================================-- -- Now we use the information from the previous pass to -- fix up usages of functions. -- llAddParams :: AList Naam (Set Naam) -> AnnExpr Naam (Set Naam) -> CExprP Naam llAddParams env (_, ANum n) = ENum n llAddParams env (_, AConstr c) = EConstr c llAddParams env (_, AVar v) = mkApChain vParams where vParams = utLookup env v mkApChain (Just vs) = foldl EAp (EVar v) (map EVar (utSetToList vs)) mkApChain Nothing = EVar v llAddParams env (_, AAp e1 e2) = EAp (llAddParams env e1) (llAddParams env e2) llAddParams env (_, ALam args body) = ELam args (llAddParams env body) llAddParams env (_, ACase sw alts) = ECase (llAddParams env sw) (map f alts) where f (naam, (params, body)) = (naam, (params, llAddParams env body)) llAddParams env (_, ALet rFlag defs body) = ELet rFlag (map fixDef defs) fixedBody where fixedBody = llAddParams env body fixDef (n, (df, (ALam vs rhs))) = let new_params = utSetToList (utSureLookup env "llAddParams1" n) in (n, ELam (new_params++vs) (llAddParams env rhs)) fixDef (n, (df, non_lambda_rhs)) = let new_params = utSetToList (utSureLookup env "llAddParams2" n) in (n, ELam new_params (llAddParams env (df, non_lambda_rhs))) -- ==========================================================-- -- The only thing that remains to be done is to flatten -- out the program, by lifting out all the let (and hence lambda) -- bindings to the top level. -- llFlatten :: CExprP Naam -> (AList Naam (CExprP Naam), CExprP Naam) llFlatten (EVar v) = ([], EVar v) llFlatten (ENum n) = ([], ENum n) llFlatten (EConstr c) = ([], EConstr c) llFlatten (EAp e1 e2) = (e1b ++ e2b, EAp e1f e2f) where (e1b, e1f) = llFlatten e1 (e2b, e2f) = llFlatten e2 llFlatten (ELam ps e1) = (e1b, ELam ps e1f) where (e1b, e1f) = llFlatten e1 llFlatten (ECase sw alts) = (swb ++ concat altsb, ECase swf altsf) where (swb, swf) = llFlatten sw altsFixed = map fixAlt alts fixAlt (name, (pars, rhs)) = (name, (pars, llFlatten rhs)) altsf = map getAltsf altsFixed getAltsf (name, (pars, (rhsb, rhsf))) = (name, (pars, rhsf)) altsb = map getAltsb altsFixed getAltsb (name, (pars, (rhsb, rhsf))) = rhsb llFlatten (ELet rf dl rhs) = (dlFlattened ++ rhsb, rhsf) where (rhsb, rhsf) = llFlatten rhs dlFixed = map fixDef dl fixDef (name, rhs) = (name, llFlatten rhs) dlFlattened = dsHere ++ concat dsInside dsHere = map here dlFixed here (name, (inDs, frhs)) = (name, frhs) dsInside = map inside dlFixed inside (name, (inDs, frhs)) = inDs -- ==========================================================-- -- The transformed program is now correct, but hard to read -- because all variables have a number on. This function -- detects non-contentious variable names and deletes -- the number, wherever possible. Also fixes up the -- free-variable list appropriately. -- llPretty :: (AList Naam (CExprP Naam), AList Naam [Naam]) -> (AList Naam (CExprP Naam), AList Naam [Naam]) llPretty (scDefs, scFrees) = let ------------------------------------------------- -- scTable tells how to rename supercombinator -- -- names only. Use to fix all SC names. -- ------------------------------------------------- scDefNames = map first scDefs scTable = getContentious scDefNames (scDefs1, scFrees1) = ( [(prettyScName scTable n, llMapCoreTree (prettyScName scTable) cexp) | (n, cexp) <- scDefs], map1st (prettyScName scTable) scFrees) ---------------------------------------------- -- Now for each supercombinator, fix up its -- -- lambda-bound variables individually -- ---------------------------------------------- lamTableTable = map makeLamTable scDefs1 makeLamTable (n, ELam vs _) = getContentious vs makeLamTable (n, non_lam_s) = [] scFrees2 = myZipWith2 fixParams scFrees1 lamTableTable fixParams (n, ps) contentious = (n, map (prettyVarName contentious) ps) scDefs2 = myZipWith2 fixDef scDefs1 lamTableTable fixDef (n, cexp) contentious = (n, llMapCoreTree (prettyVarName contentious) cexp) getContentious names = let sortedNames = sort names gc [] = [] gc [x] = [] gc (x:y:xys) | rootName x == rootName y = x:y:gc (y:xys) | otherwise = gc (y:xys) contentions = nub (gc sortedNames) in contentions prettyScName contentions n | head n == '_' && n `notElem` contentions = rootName n | otherwise = n prettyVarName contentions n | head n /= '_' && n `notElem` contentions = rootName n | otherwise = n rootName = takeWhile (/= ')') in (scDefs2, scFrees2) -- ==========================================================-- -- llSplitSet :: Set Naam -> (Set Naam, Set Naam) llSplitSet list = let split (facc, vacc) n = if head n == '_' then (n:facc, vacc) else (facc, n:vacc) in case foldl split ([],[]) (utSetToList list) of (fs, vs) -> (utSetFromList fs, utSetFromList vs) -- ==========================================================-- -- llZapBuiltins :: [Naam] -> Eqn -> Eqn llZapBuiltins builtins (EqnNVC n v c) = EqnNVC n v (utSetFromList (filter (`notElem` builtins) (utSetToList c))) -- ==========================================================-- -- llSolveIteratively :: [Eqn] -> AList Naam (Set Naam) llSolveIteratively eqns = loop eqns initSets where initSets = [(n, utSetEmpty) | EqnNVC n v c <- eqns] loop eqns aSet = let newSet = map (sub_eqn aSet) eqns in if newSet == aSet then newSet else loop eqns newSet sub_eqn subst (EqnNVC n v c) = let allVars = utSetToList v ++ utSetToList c allSub = utSetUnionList (map sub allVars) sub var = utLookupDef subst var (utSetSingleton var) in case llSplitSet allSub of (facc, vacc) -> (n, vacc) -- ==========================================================-- -- Map a function over a core tree. -- *** Haskell-B 9972 insists on restricted signature, why? *** -- llMapCoreTree :: (Naam -> Naam) -> CExprP Naam -> CExprP Naam llMapCoreTree f (EVar v) = EVar (f v) llMapCoreTree f (ENum n) = ENum n llMapCoreTree f (EConstr c) = EConstr c llMapCoreTree f (ELam vs e) = ELam (map f vs) (llMapCoreTree f e) llMapCoreTree f (EAp e1 e2) = EAp (llMapCoreTree f e1) (llMapCoreTree f e2) llMapCoreTree f (ELet rf dl e) = ELet rf [(f n, llMapCoreTree f rhs) | (n, rhs) <- dl] (llMapCoreTree f e) llMapCoreTree f (ECase sw alts) = ECase (llMapCoreTree f sw) [(cn, (map f ps, llMapCoreTree f rhs)) | (cn, (ps, rhs)) <- alts] -- ==========================================================-- -- llMain :: [Naam] -> CExprP Naam -> Bool -> (CExprP Naam, AList Naam [Naam]) llMain builtInNames expr doPretty = let fvAnnoTree = (llFreeVars . second . llUnique 0 initialRenamer . llName . llMergeLams . deDependancy) expr builtInFns = filter ((=='_').head) builtInNames initFreeEnv = [(n, utSetEmpty) | n <- builtInNames] initialRenamer = map (\n -> (tail n, n)) builtInFns eqns = llEqns fvAnnoTree eqns_with_builtins_zapped = map (llZapBuiltins builtInFns) eqns eqns_solved = llSolveIteratively eqns_with_builtins_zapped (scDefs, mainE) = llFlatten (llAddParams eqns_solved fvAnnoTree) (prettyScDefs, prettyNewParams) = if doPretty then llPretty (scDefs, scParams) else (scDefs, scParams) scParams = map2nd utSetToList eqns_solved exprReconstituted = ELet True prettyScDefs mainE exprDepended = deDependancy exprReconstituted in (exprDepended, prettyNewParams) -- ==========================================================-- -- === end LambdaLift5.hs ===-- -- ==========================================================--