home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 2 / DATAFILE_PDCD2.iso / utilities / _gofer / !Gofer / archives / Demos / Modular / Laziness < prev    next >
Text File  |  1993-02-12  |  7KB  |  177 lines
  1. ------------------------------------------------------------------------------
  2. --The files in this directory are based on the programs described in:
  3. --
  4. --    A Modular fully-lazy lambda lifter in Haskell
  5. --    Simon L. Peyton Jones and David Lester
  6. --    Software -- Practice and Experience
  7. --    Vol 21(5), pp.479-506
  8. --    MAY 1991
  9. --
  10. --See the Readme file for more details.
  11. ------------------------------------------------------------------------------
  12.  
  13. -- 5.4 A fully lazy lambda lifter
  14.  
  15. fullyLazyLift :: Expression -> [SCDefn]
  16. fullyLazyLift  = lambdaLift . float . rename
  17.                    . identifyMFEs . addLevels . separateLams
  18.  
  19. -- 5.5 Separating the lambdas
  20.  
  21. separateLams                 :: Expression -> Expression
  22. separateLams (EVar v)         = EVar v
  23. separateLams (EConst k)       = EConst k
  24. separateLams (EAp e1 e2)      = EAp (separateLams e1) (separateLams e2)
  25. separateLams (ELam args body) = foldr mkSingleLam body args
  26.                                 where mkSingleLam arg bod = ELam [arg] body
  27. separateLams (ELet isRec defns body)
  28.                               = ELet isRec
  29.                                      [(n,separateLams rhs)|(n,rhs)<-defns]
  30.                                      (separateLams body)
  31.  
  32. -- 5.6 Adding level numbers
  33.  
  34. type Level     = Int
  35.  
  36. addLevels     :: Expression -> AnnExpr (Name,Level) Level
  37. addLevels      = freeToLevel . freeVars
  38.  
  39. freeToLevel   :: AnnExpr Name (Set Name) -> AnnExpr (Name,Level) Level
  40. freeToLevel e  = freeToLevel_e 0 [] e
  41.  
  42. freeSetToLevel         :: Set Name -> Assn Name Level -> Level
  43. freeSetToLevel free env = maximum (0:map (assLookup env) (setToList free))
  44.  
  45. freeToLevel_e :: Level
  46.                    -> Assn Name Level
  47.                         -> AnnExpr Name (Set Name)
  48.                              -> AnnExpr (Name,Level) Level
  49.  
  50. freeToLevel_e lev env (_, AConst k)  = (0, AConst k)
  51. freeToLevel_e lev env (_, AVar v)    = (assLookup env v, AVar v)
  52. freeToLevel_e lev env (_, AAp e1 e2) = (max (levelOf e1') (levelOf e2'),
  53.                                         AAp e1' e2')
  54.                                        where e1' = freeToLevel_e lev env e1
  55.                                              e2' = freeToLevel_e lev env e2
  56.  
  57. freeToLevel_e lev env (free, ALam args body)
  58.  = (freeSetToLevel free env, ALam args' body')
  59.  where body' = freeToLevel_e (lev+1) (args'++env) body
  60.        args' = zip args (repeat (lev+1))
  61.  
  62. freeToLevel_e lev env (free, ALet isRec defns body)
  63.  = (levelOf body', ALet isRec defns' body')
  64.  where binders            = bindersOf defns
  65.        freeRhsVars        = setUnionList [free | (free,_) <- rhssOf defns]
  66.        maxRhsLevel        = freeSetToLevel freeRhsVars
  67.                                            ([(name,0) | name<-binders] ++ env)
  68.        defns'             = map freeToLevel_d defns
  69.        body'              = freeToLevel_e lev (bindersOf defns' ++ env) body
  70.        freeToLevel_d (name,rhs)
  71.                           = ((name,levelOf rhs'),rhs')
  72.                             where rhs' = freeToLevel_e lev envRhs rhs
  73.        envRhs | isRec     = [(name,maxRhsLevel) | name<-binders] ++ env
  74.               | not isRec = env
  75.  
  76. levelOf           :: AnnExpr a Level -> Level
  77. levelOf (level, _) = level
  78.  
  79. -- 5.7 Identifying MFEs
  80.  
  81. identifyMFEs :: AnnExpr (Name,Level) Level -> Expr (Name,Level)
  82. identifyMFEs = identifyMFEs_e 0
  83.  
  84. notMFECandidate (AConst k) = True
  85. notMFECandidate (AVar v)   = True
  86. notMFECandidate _          = False   -- everything else is a candidate
  87.  
  88. identifyMFEs_e :: Level -> AnnExpr (Name,Level) Level -> Expr (Name,Level)
  89. identifyMFEs_e cxt (level,e)
  90.       | level==cxt || notMFECandidate e  =  e'
  91.       | otherwise                        = transformMFE level e'
  92.       where e' = identifyMFEs_e1 level e
  93.  
  94. transformMFE level e = ELet nonRecursive [(("v",level),e)] (EVar "v")
  95.  
  96. identifyMFEs_e1 level (AConst k)  = EConst k
  97. identifyMFEs_e1 level (AVar v)    = EVar v
  98. identifyMFEs_e1 level (AAp e1 e2) = EAp (identifyMFEs_e level e1)
  99.                                         (identifyMFEs_e level e2)
  100. identifyMFEs_e1 level (ALam args body)
  101.                                   = ELam args (identifyMFEs_e argLevel body)
  102.                                     where ((_,argLevel):_) = args
  103. identifyMFEs_e1 level (ALet isRec defns body)
  104.  = ELet isRec defns' body'
  105.    where body'  = identifyMFEs_e level body
  106.          defns' = [(binder,identifyMFEs_e level rhs) | (binder,rhs) <- defns]
  107.  
  108. -- 5.8 Renaming
  109.  
  110. rename  :: Expr (Name,a) -> Expr (Name,a)
  111. rename e = e' where (_,e') = rename_e [] initialNameSupply e
  112.  
  113. rename_e :: Assn Name Name -> NameSupply -> Expr (Name,a)
  114.                 -> (NameSupply, Expr (Name, a))
  115. rename_e env ns (EVar v)    = (ns,EVar (assLookup env v))
  116. rename_e env ns (EConst k)  = (ns, EConst k)
  117. rename_e env ns (EAp e1 e2) = (ns'', EAp e1' e2')
  118.                               where (ns', e1') = rename_e env ns  e1
  119.                                     (ns'',e2') = rename_e env ns' e2
  120. rename_e env ns (ELam args body)
  121.   = (ns'', ELam args' body')         -- BUG????
  122.   where (ns', args') = mapAccuml newBinder ns args
  123.         (ns'',body') = rename_e (assocBinders args args' ++ env) ns' body
  124. rename_e env ns (ELet isRec defns body)
  125.   = (ns''', ELet isRec (zip binders' values') body')
  126.   where (ns',  body')      = rename_e env' ns body
  127.         binders            = bindersOf defns
  128.         (ns'', binders')   = mapAccuml newBinder ns' binders
  129.         env'               = assocBinders binders binders' ++ env
  130.         (ns''',values')    = mapAccuml (rename_e rhsEnv) ns'' (rhssOf defns)
  131.         rhsEnv | isRec     = env'
  132.                | not isRec = env
  133.  
  134. newBinder ns (name,info) = (ns',(name',info))
  135.                            where (ns',name') = newName ns name
  136.  
  137. assocBinders                 :: [(Name,a)] -> [(Name,a)] -> Assn Name Name
  138. assocBinders binders binders' = zip (map fst binders) (map fst binders')
  139.  
  140. -- 5.9 Floating
  141.  
  142. float  :: Expr (Name,Level) -> Expression
  143. float e = install floatedDefns e' where (floatedDefns,e') = float_e e
  144.  
  145. type FloatedDefns = [(Level, IsRec, [Defn Name])]
  146.  
  147. install             :: FloatedDefns -> Expression -> Expression
  148. install defnGroups e = foldr installGroup e defnGroups
  149.  where installGroup (level,isRec,defns) e = ELet isRec defns e
  150.  
  151. float_e            :: Expr (Name,Level) -> (FloatedDefns, Expression)
  152. float_e (EConst k)  = ([], EConst k)
  153. float_e (EVar v)    = ([], EVar v)
  154. float_e (EAp e1 e2) = (fd1++fd2, EAp e1' e2')
  155.                       where (fd1, e1') = float_e e1
  156.                             (fd2, e2') = float_e e2
  157.  
  158. float_e (ELam args body)
  159.  = (outerLevelDefns, ELam args' (install thisLevelDefns body'))
  160.  where args'                 = [ arg | (arg,level) <- args ]
  161.        (_, thisLevel)        = head args
  162.        (floatedDefns, body') = float_e body
  163.        thisLevelDefns        = filter groupIsThisLevel       floatedDefns
  164.        outerLevelDefns       = filter (not.groupIsThisLevel) floatedDefns
  165.        groupIsThisLevel (level,_,_) = level >= thisLevel
  166.  
  167. float_e (ELet isRec defns body)
  168.  = (rhsFloatDefns ++ [thisGroup] ++ bodyFloatDefns, body')
  169.  where (bodyFloatDefns, body') = float_e body
  170.        (rhsFloatDefns, defns') = mapAccuml float_defn [] defns
  171.        thisGroup               = (thisLevel, isRec, defns')
  172.        (_, thisLevel)          = head (bindersOf defns)
  173.  
  174. float_defn floatedDefns ((name,level),rhs)
  175.  = (rhsFloatDefns ++ floatedDefns, (name, rhs'))
  176.  where (rhsFloatDefns, rhs') = float_e rhs
  177.