1 2 -- ==========================================================-- 3 -- === Add parameters to supercombinators which ===-- 4 -- === otherwise return functions EtaAbstract.hs ===-- 5 -- ==========================================================-- 6 7 module EtaAbstract where 8 import BaseDefs 9 import Utils 10 import MyUtils 11 12 13 -- ==========================================================-- 14 -- Doesn't assume that the tree has been lambda-lifted. 15 -- It does however assume that all lambda-terms are 16 -- directly attached to a let-binding. 17 -- 18 eaEtaAbstract :: AnnExpr Naam TExpr -> 19 AnnExpr Naam TExpr 20 21 eaEtaAbstract ae@(tau, AVar v) = ae 22 eaEtaAbstract ae@(tau, ANum n) = ae 23 eaEtaAbstract ae@(tau, AConstr c) = ae 24 eaEtaAbstract ae@(tau, AAp e1 e2) 25 = (tau, AAp (eaEtaAbstract e1) (eaEtaAbstract e2)) 26 eaEtaAbstract ae@(tau, ACase sw alts) 27 = (tau, ACase (eaEtaAbstract sw) 28 [(n, (ps, eaEtaAbstract rhs)) | (n, (ps, rhs)) <- alts]) 29 eaEtaAbstract ae@(tau, ALam vs e) 30 = (tau, ALam vs (eaEtaAbstract e)) 31 32 eaEtaAbstract ae@(tau, ALet rf defs body) 33 = let typeInfo = [eaUncurry ty | (n, (ty, rhs)) <- defs] 34 mergedDefs = map2nd mergeLams defs 35 fixedDefs = myZipWith2 fixOne mergedDefs typeInfo 36 fixOne sc@(n, (tau, ALam vs e)) (argTs, resT) 37 | length vs == length argTs = sc 38 | length vs > length argTs = panic "eaEtaAbstract" 39 | length vs < length argTs = eaMain sc argTs resT 40 fixOne sc@(n, (tau, non_lam_b)) (argTs, resT) 41 | null argTs = sc 42 | otherwise = eaMain (n, (tau, ALam [] (tau, non_lam_b))) argTs resT 43 mergeLams ae@(tau, ALam vs (tau2, ALam vs2 e)) 44 = mergeLams (tau, ALam (vs++vs2) e) 45 mergeLams anyThingElse = anyThingElse 46 in (tau, ALet rf fixedDefs (eaEtaAbstract body)) 47 48 49 -- ==========================================================-- 50 -- 51 eaMain :: (Naam, AnnExpr Naam TExpr) -> 52 [TExpr] -> 53 TExpr -> 54 (Naam, AnnExpr Naam TExpr) 55 56 eaMain (scname, (tau, ALam vs (tau2, rhs))) argTs resT 57 = let actualArity = length vs 58 reqdArity = length argTs 59 newArgsReqd = reqdArity - actualArity 60 newArgs = eaMakeNewArgs newArgsReqd vs 61 newArgsTypes = myZip2 newArgs (drop actualArity argTs) 62 appArgTLists = map ((flip drop) argTs) 63 (actualArity `myIntsFromTo` (reqdArity-1)) 64 appTypes = map (eaCurry resT) appArgTLists 65 newBody = eaMakeApChain (myZip2 newArgsTypes appTypes) (tau2, rhs) 66 in (scname, (tau, ALam (vs++newArgs) newBody)) 67 68 69 -- ==========================================================-- 70 -- 71 eaMakeApChain :: [((Naam, TExpr), TExpr)] -> 72 AnnExpr Naam TExpr -> 73 AnnExpr Naam TExpr 74 75 eaMakeApChain [] app = app 76 eaMakeApChain (((v, vtype), vaptype):rest) app 77 = eaMakeApChain rest (vaptype, AAp app (vtype, AVar v)) 78 79 80 -- ==========================================================-- 81 -- 82 eaMakeNewArgs :: Int -> [Naam] -> [Naam] 83 84 eaMakeNewArgs n vs 85 = let leadingvs = filter (not.null) (map (takeWhile (== 'v')) vs) 86 root = last (sort ("":leadingvs)) ++ "v" 87 newNames = map f (1 `myIntsFromTo` n) 88 f n = root ++ show (n :: Int) 89 in newNames 90 91 92 -- ==========================================================-- 93 -- 94 eaCurry :: TExpr -> [TExpr] -> TExpr 95 96 eaCurry resT [] = resT 97 eaCurry resT (argT:argTs) = TArr argT (eaCurry resT argTs) 98 99 100 -- ==========================================================-- 101 -- 102 eaUncurry :: TExpr -> ([TExpr], TExpr) 103 104 eaUncurry (TVar tv) = ([], TVar tv) 105 106 eaUncurry (TArr t1 t2) 107 = let (rest, final) = eaUncurry t2 108 in (t1:rest, final) 109 110 eaUncurry (TCons tcon targs) 111 = ([], TCons tcon targs) 112 113 114 -- ==========================================================-- 115 -- === end EtaAbstract.hs ===-- 116 -- ==========================================================-- 117 118