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 Mark all the recursive functions as deforestable.  Might as well,
 124 since they will be in treeless form anyway.  This helps to cope with
 125 overloaded functions, where the compiler earlier lifts out the
 126 dictionary deconstruction.
 127
 128 > convRecBinds bs e =
 129 >       convExpr e                              `thenUs` \e'   ->
 130 >       mapUs convExpr es                       `thenUs` \es'  ->
 131 >       mapUs (subst s) es'                     `thenUs` \es'' ->
 132 >       subst s e'                              `thenUs` \e''  ->
 133 >       returnUs (zip vs' es', e')
 134 >    where
 135 >       (vs,es) = unzip bs
 136 >       vs'  = map mkDeforestable vs
 137 >       s = zip vs (map (Var . DefArgVar) vs')
 138 >       mkDeforestable v = replaceIdInfo v (addInfo (getIdInfo v) DoDeforest)
 139
 140 > convAtom :: DefAtom -> UniqSM DefAtom
 141 >
 142 > convAtom (VarArg v) =
 143 >       convArg v                               `thenUs` \v ->
 144 >       returnUs (VarArg v)
 145 > convAtom (LitArg l) =
 146 >       returnUs (LitArg l)             -- XXX
 147
 148 > convArg :: DefBindee -> UniqSM DefBindee
 149 >
 150 > convArg (DefArgExpr e) =
 151 >       convExpr e                              `thenUs` \e ->
 152 >       returnUs (DefArgExpr e)
 153 > convArg e@(Label _ _)  =
 154 >       panic "TreelessForm(convArg): Label _ _"
 155 > convArg e@(DefArgVar id)  =
 156 >       panic "TreelessForm(convArg): DefArgVar _ _"
 157
 158 > convCaseAlts :: DefCaseAlternatives -> UniqSM DefCaseAlternatives
 159 >
 160 > convCaseAlts (AlgAlts as def) =
 161 >       mapUs convAlgAlt as                     `thenUs` \as ->
 162 >       convDefault def                         `thenUs` \def ->
 163 >       returnUs (AlgAlts as def)
 164 > convCaseAlts (PrimAlts as def) =
 165 >       mapUs convPrimAlt as                    `thenUs` \as ->
 166 >       convDefault def                         `thenUs` \def ->
 167 >       returnUs (PrimAlts as def)
 168
 169 > convAlgAlt  (c, vs, e) =
 170 >       convExpr e                              `thenUs` \e ->
 171 >       returnUs (c, vs, e)
 172 > convPrimAlt (l, e) =
 173 >       convExpr e                              `thenUs` \e ->
 174 >       returnUs (l, e)
 175
 176 > convDefault NoDefault =
 177 >       returnUs NoDefault
 178 > convDefault (BindDefault id e) =
 179 >       convExpr e                              `thenUs` \e ->
 180 >       returnUs (BindDefault id e)
 181
 182 > newLet :: DefExpr -> (DefExpr -> DefExpr) -> UniqSM DefExpr
 183 > newLet e body =
 184 >       d2c e                                   `thenUs` \core_expr ->
 185 >       newDefId (coreExprType core_expr)       `thenUs` \new_id ->
 186 >       returnUs (Let (NonRec new_id e) (body (Var (DefArgVar new_id))))