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