ghc/compiler/deforest/TreelessForm.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TreelessForm]{Convert Arbitrary expressions into treeless form}
   5
   6 >#include "HsVersions.h"
   7 >
   8 > module TreelessForm (
   9 >       convertToTreelessForm
  10 >       ) where
  11 >
  12 > import DefSyn
  13 > import DefUtils
  14
  15 > import CmdLineOpts    ( SwitchResult, switchIsOn )
  16 > import CoreUtils      ( coreExprType )
  17 > import Id             ( replaceIdInfo, getIdInfo )
  18 > import IdInfo
  19 > import Maybes         ( Maybe(..) )
  20 > import Outputable
  21 > import SimplEnv       ( SwitchChecker(..) )
  22 > import UniqSupply
  23 > import Util
  24
  25 > -- tmp
  26 > import Pretty
  27 > import Def2Core
  28
  29 Very simplistic approach to begin with:
  30
  31 case e of {...}  ====>  let x = e in case x of {...}
  32 x e1 ... en      ====>  let x1 = e1 in ... let xn = en in (x x1 ... xn)
  33
  34 ToDo: make this better.
  35
  36 > convertToTreelessForm
  37 >       :: SwitchChecker sw
  38 >       -> DefExpr
  39 >       -> UniqSM DefExpr
  40 >
  41 > convertToTreelessForm sw e
  42 >       = convExpr e
  43 >
  44 > convExpr
  45 >       :: DefExpr
  46 >       -> UniqSM DefExpr
  47
  48 > convExpr e = case e of
  49 >
  50 >       Var (DefArgExpr e) ->
  51 >               panic "TreelessForm(substTy): Var (DefArgExpr _)"
  52 >
  53 >       Var (Label l e) ->
  54 >               panic "TreelessForm(substTy): Var (Label _ _)"
  55 >
  56 >       Var (DefArgVar id) -> returnUs e
  57 >
  58 >       Lit l -> returnUs e
  59 >
  60 >       Con c ts es ->
  61 >               mapUs convAtom es               `thenUs` \es ->
  62 >               returnUs (Con c ts es)
  63 >
  64 >       Prim op ts es ->
  65 >               mapUs convAtom es               `thenUs` \es ->
  66 >               returnUs (Prim op ts es)
  67 >
  68 >       Lam vs e ->
  69 >               convExpr e                      `thenUs` \e ->
  70 >               returnUs (Lam vs e)
  71 >
  72 >       CoTyLam alpha e ->
  73 >               convExpr e                      `thenUs` \e ->
  74 >               returnUs (CoTyLam alpha e)
  75 >
  76 >       App e v ->
  77 >               convExpr e                      `thenUs` \e ->
  78 >               case v of
  79 >                 LitArg l -> returnUs (App e v)
  80 >                 VarArg v' ->
  81 >                   case v' of
  82 >                       DefArgVar _ -> panic "TreelessForm(convExpr): DefArgVar"
  83 >                       DefArgExpr (Var (DefArgVar id))
  84 >                               | (not.deforestable) id ->
  85 >                                       returnUs (App e v)
  86 >                       DefArgExpr e' ->
  87 >                          newLet e' (\id -> App e (VarArg
  88 >                                                       (DefArgExpr id)))
  89 >
  90 >       CoTyApp e ty ->
  91 >               convExpr e                      `thenUs` \e ->
  92 >               returnUs (CoTyApp e ty)
  93 >
  94 >       Case e ps ->
  95 >               convCaseAlts ps                 `thenUs` \ps ->
  96 >               case e of
  97 >                       Var (DefArgVar id)  | (not.deforestable) id ->
  98 >                               returnUs (Case e ps)
  99 >                       Prim op ts es -> returnUs (Case e ps)
 100 >                       _ -> d2c e              `thenUs` \e' ->
 101 >                            newLet e (\v -> Case v ps)
 102 >
 103 >       Let (NonRec id e) e' ->
 104 >               convExpr e                      `thenUs` \e  ->
 105 >               convExpr e'                     `thenUs` \e' ->
 106 >               returnUs (Let (NonRec id e) e')
 107 >
 108 >       Let (Rec bs) e ->
 109 >--             convRecBinds bs e               `thenUs` \(bs,e) ->
 110 >--             returnUs (Let (Rec bs) e)
 111 >               convExpr e                      `thenUs` \e ->
 112 >               mapUs convRecBind bs            `thenUs` \bs ->
 113 >               returnUs (Let (Rec bs) e)
 114 >          where
 115 >               convRecBind (v,e) =
 116 >                       convExpr e              `thenUs` \e ->
 117 >                       returnUs (v,e)
 118 >
 119 >       SCC l e ->
 120 >               convExpr e                      `thenUs` \e ->
 121 >               returnUs (SCC l e)
 122 >
 123 >       Coerce _ _ _ -> panic "TreelessForm:convExpr:Coerce"
 124
 125 Mark all the recursive functions as deforestable.  Might as well,
 126 since they will be in treeless form anyway.  This helps to cope with
 127 overloaded functions, where the compiler earlier lifts out the
 128 dictionary deconstruction.
 129
 130 > convRecBinds bs e =
 131 >       convExpr e                              `thenUs` \e'   ->
 132 >       mapUs convExpr es                       `thenUs` \es'  ->
 133 >       mapUs (subst s) es'                     `thenUs` \es'' ->
 134 >       subst s e'                              `thenUs` \e''  ->
 135 >       returnUs (zip vs' es', e')
 136 >    where
 137 >       (vs,es) = unzip bs
 138 >       vs'  = map mkDeforestable vs
 139 >       s = zip vs (map (Var . DefArgVar) vs')
 140 >       mkDeforestable v = replaceIdInfo v (addInfo (getIdInfo v) DoDeforest)
 141
 142 > convAtom :: DefAtom -> UniqSM DefAtom
 143 >
 144 > convAtom (VarArg v) =
 145 >       convArg v                               `thenUs` \v ->
 146 >       returnUs (VarArg v)
 147 > convAtom (LitArg l) =
 148 >       returnUs (LitArg l)             -- XXX
 149
 150 > convArg :: DefBindee -> UniqSM DefBindee
 151 >
 152 > convArg (DefArgExpr e) =
 153 >       convExpr e                              `thenUs` \e ->
 154 >       returnUs (DefArgExpr e)
 155 > convArg e@(Label _ _)  =
 156 >       panic "TreelessForm(convArg): Label _ _"
 157 > convArg e@(DefArgVar id)  =
 158 >       panic "TreelessForm(convArg): DefArgVar _ _"
 159
 160 > convCaseAlts :: DefCaseAlternatives -> UniqSM DefCaseAlternatives
 161 >
 162 > convCaseAlts (AlgAlts as def) =
 163 >       mapUs convAlgAlt as                     `thenUs` \as ->
 164 >       convDefault def                         `thenUs` \def ->
 165 >       returnUs (AlgAlts as def)
 166 > convCaseAlts (PrimAlts as def) =
 167 >       mapUs convPrimAlt as                    `thenUs` \as ->
 168 >       convDefault def                         `thenUs` \def ->
 169 >       returnUs (PrimAlts as def)
 170
 171 > convAlgAlt  (c, vs, e) =
 172 >       convExpr e                              `thenUs` \e ->
 173 >       returnUs (c, vs, e)
 174 > convPrimAlt (l, e) =
 175 >       convExpr e                              `thenUs` \e ->
 176 >       returnUs (l, e)
 177
 178 > convDefault NoDefault =
 179 >       returnUs NoDefault
 180 > convDefault (BindDefault id e) =
 181 >       convExpr e                              `thenUs` \e ->
 182 >       returnUs (BindDefault id e)
 183
 184 > newLet :: DefExpr -> (DefExpr -> DefExpr) -> UniqSM DefExpr
 185 > newLet e body =
 186 >       d2c e                                   `thenUs` \core_expr ->
 187 >       newDefId (coreExprType core_expr)       `thenUs` \new_id ->
 188 >       returnUs (Let (NonRec new_id e) (body (Var (DefArgVar new_id))))