home *** CD-ROM | disk | FTP | other *** search
/ back2roots/padua / padua.7z / padua / lang / gofer223.lha / demos / modular / LambdaLift < prev    next >
Encoding:
Text File  |  1991-11-19  |  4.9 KB  |  126 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. -- 3.3 A data type for compilation -- a happy ending:
  14.  
  15. data Constant           = CNum Int | CBool Bool | CFun Name
  16. type Name               = String
  17.  
  18. data Expr binder        = EVar   Name                              |
  19.                           EConst Constant                          |
  20.                           EAp    (Expr binder) (Expr binder)       |
  21.                           ELet   IsRec [Defn binder] (Expr binder) |
  22.                           ELam   [binder] (Expr binder)
  23.  
  24. type Defn binder        = (binder, Expr binder)
  25.  
  26. type Expression         = Expr Name
  27.  
  28. type IsRec              = Bool
  29. recursive               = True
  30. nonRecursive            = False
  31.  
  32. type AnnExpr  binder a  = (a, AnnExpr' binder a)
  33. data AnnExpr' binder a  = AVar   Name                                        |
  34.                           AConst Constant                                    |
  35.                           AAp    (AnnExpr binder a) (AnnExpr binder a)       |
  36.                           ALet   IsRec [AnnDefn binder a] (AnnExpr binder a) |
  37.                           ALam   [binder] (AnnExpr binder a)
  38.  
  39. type AnnDefn binder a   = (binder, AnnExpr binder a)
  40.  
  41. bindersOf              :: [(binder,rhs)] -> [binder]
  42. bindersOf defns         = [ binder | (binder,rhs) <- defns ]
  43.  
  44. rhssOf                 :: [(binder,rhs)] -> [rhs]
  45. rhssOf defns            = [ rhs | (binder, rhs) <- defns ]
  46.  
  47. -- 4 Lambda lifting:
  48.  
  49. lambdaLift :: Expression -> [SCDefn]
  50. lambdaLift  = collectSCs . abstract . freeVars
  51.  
  52. type SCDefn = (Name, [Name], Expression)
  53.  
  54. -- 4.2 Free variables:
  55.  
  56. freeVars            :: Expression -> AnnExpr Name (Set Name)
  57.  
  58. freeVars (EConst k)  = (setEmpty, AConst k)
  59. freeVars (EVar v)    = (setSingleton v, AVar v)
  60. freeVars (EAp e1 e2) = (setUnion (freeVarsOf e1') (freeVarsOf e2'),AAp e1' e2')
  61.                         where e1' = freeVars e1
  62.                               e2' = freeVars e2
  63.  
  64. freeVars (ELam args body)
  65.   = (setDifference (freeVarsOf body') (setFromList args), ALam args body')
  66.     where body' = freeVars body
  67.  
  68. freeVars (ELet isRec defns body)
  69.   = (setUnion defnsFree bodyFree, ALet isRec defns' body')
  70.     where binders        = bindersOf defns
  71.           binderSet      = setFromList binders
  72.           values'        = map freeVars (rhssOf defns)
  73.           defns'         = zip binders values'
  74.           freeInValues   = foldr setUnion setEmpty (map freeVarsOf values')
  75.           defnsFree
  76.              | isRec     = setDifference freeInValues binderSet
  77.              | not isRec = freeInValues
  78.           body'          = freeVars body
  79.           bodyFree       = setDifference (freeVarsOf body') binderSet
  80.  
  81. freeVarsOf                 :: AnnExpr Name (Set Name) -> Set Name
  82. freeVarsOf (freeVars, expr) = freeVars
  83.  
  84. -- 4.3 Generating supercombinators:
  85.  
  86. abstract               :: AnnExpr Name (Set Name) -> Expression
  87. abstract (_, AVar v)    = EVar v
  88. abstract (_, AConst k)  = EConst k
  89. abstract (_, AAp e1 e2) = EAp (abstract e1) (abstract e2)
  90. abstract (free, ALam args body)
  91.                         = foldl EAp sc (map EVar fvList)
  92.                           where fvList = setToList free
  93.                                 sc     = ELam (fvList++args) (abstract body)
  94. abstract (_,ALet isRec defns body)
  95.                         = ELet isRec
  96.                                [(name,abstract body) | (name,body) <- defns]
  97.                                (abstract body)
  98.  
  99. -- 4.4 Collecting supercombinators:
  100.  
  101. collectSCs   :: Expression -> [SCDefn]
  102. collectSCs e  = [("$main",[],e')] ++ bagToList scs
  103.                 where (_, scs, e') = collectSCs_e initialNameSupply e
  104.  
  105. collectSCs_e :: NameSupply -> Expression -> (NameSupply,Bag SCDefn,Expression)
  106. collectSCs_e ns (EConst k)  = (ns, bagEmpty, EConst k)
  107. collectSCs_e ns (EVar v)    = (ns, bagEmpty, EVar v)
  108. collectSCs_e ns (EAp e1 e2) = (ns'', bagUnion scs1 scs2, EAp e1' e2')
  109.                               where (ns',  scs1, e1') = collectSCs_e ns  e1
  110.                                     (ns'', scs2, e2') = collectSCs_e ns' e2
  111.  
  112. collectSCs_e ns (ELam args body)
  113.  = (ns'', bagInsert (name,args,body') bodySCs, EConst (CFun name))
  114.    where (ns', bodySCs,body') = collectSCs_e ns body
  115.          (ns'',name)          = newName ns' "SC"
  116.  
  117. collectSCs_e ns (ELet isRec defns body)
  118.  = (ns'', scs, ELet isRec defns' body')
  119.    where ((ns'',scs),defns')   = mapAccuml collectSCs_d (ns',bodySCs) defns
  120.          (ns', bodySCs, body') = collectSCs_e ns body
  121.  
  122.          collectSCs_d (ns,scs) (name,value)
  123.                               = ((ns',bagUnion scs scs'), (name, value'))
  124.                                 where (ns',scs',value') = collectSCs_e ns value
  125.  
  126.