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