ghc/compiler/deforest/Def2Core.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[Def2Core]{Translate a DefProgram back into a CoreProgram}
   5
   6 >#include "HsVersions.h"
   7 >
   8 > module Def2Core (
   9 >       def2core, d2c,
  10 >
  11 >       -- and to make the interface self-sufficient, all this stuff:
  12 >       DefBinding(..), SYN_IE(UniqSM),
  13 >       GenCoreBinding, Id, DefBindee,
  14 >       defPanic
  15 >       ) where
  16
  17 > import DefSyn
  18 > import DefUtils
  19 >
  20 > import Outputable
  21 > import Pretty
  22 > import UniqSupply
  23 > import Util
  24
  25
  26 > def2core :: DefProgram -> UniqSM [CoreBinding]
  27 > def2core prog = mapUs defBinding2core prog
  28
  29 > defBinding2core :: DefBinding -> UniqSM CoreBinding
  30 > defBinding2core (NonRec v e) =
  31 >       d2c e `thenUs` \e' ->
  32 >       returnUs (NonRec v e')
  33 > defBinding2core (Rec bs) =
  34 >       mapUs recBind2core bs `thenUs` \bs' ->
  35 >       returnUs (Rec bs')
  36 >               where recBind2core (v,e)
  37 >                       = d2c e `thenUs` \e' ->
  38 >                         returnUs (v, e')
  39
  40
  41 > defAtom2core :: DefAtom -> UniqSM (CoreArg, Maybe CoreExpr)
  42 > defAtom2core atom = case atom of
  43 >       LitArg l -> returnUs (LitArg l, Nothing)
  44 >       VarArg (DefArgVar id) -> returnUs (VarArg id, Nothing)
  45 >       VarArg (DefArgExpr (Var (DefArgVar id))) ->
  46 >               returnUs (VarArg id, Nothing)
  47 >       VarArg (DefArgExpr (Lit l)) ->
  48 >               returnUs (LitArg l, Nothing)
  49 >       VarArg (DefArgExpr e) ->
  50 >               d2c e           `thenUs` \e' ->
  51 >               newTmpId (coreExprType e')      `thenUs` \new_id ->
  52 >               returnUs (VarArg new_id, Just e')
  53 >       VarArg (Label _ _) ->
  54 >               panic "Def2Core(defAtom2core): VarArg (Label _ _)"
  55
  56 > d2c :: DefExpr -> UniqSM CoreExpr
  57 > d2c e = case e of
  58 >
  59 >       Var (DefArgExpr e) ->
  60 >               panic "Def2Core(d2c): Var (DefArgExpr _)"
  61 >
  62 >       Var (Label _ _) ->
  63 >               panic "Def2Core(d2c): Var (Label _ _)"
  64 >
  65 >       Var (DefArgVar v) ->
  66 >               returnUs (Var v)
  67 >
  68 >       Lit l ->
  69 >               returnUs (Lit l)
  70 >
  71 >       Con c ts as ->
  72 >               mapUs defAtom2core as   `thenUs` \atom_expr_pairs ->
  73 >               returnUs (
  74 >                       foldr (\(a,b) -> mkLet a b)
  75 >                               (Con c ts (map fst atom_expr_pairs))
  76 >                               atom_expr_pairs)
  77 >
  78 >       Prim op ts as ->
  79 >               mapUs defAtom2core as   `thenUs` \atom_expr_pairs ->
  80 >               returnUs (
  81 >                       foldr (\(a,b) -> mkLet a b)
  82 >                               (Prim op ts (map fst atom_expr_pairs))
  83 >                               atom_expr_pairs)
  84 >
  85 >       Lam vs e ->
  86 >               d2c e                   `thenUs` \e' ->
  87 >               returnUs (Lam vs e')
  88 >
  89 >       CoTyLam alpha e ->
  90 >               d2c e                   `thenUs` \e' ->
  91 >               returnUs (CoTyLam alpha e')
  92 >
  93 >       App e v       ->
  94 >               d2c e                   `thenUs` \e' ->
  95 >               defAtom2core v          `thenUs` \(v',e'') ->
  96 >               returnUs (mkLet v' e'' (App e' v'))
  97 >
  98 >       CoTyApp e t     ->
  99 >               d2c e                   `thenUs` \e' ->
 100 >               returnUs (CoTyApp e' t)
 101 >
 102 >       Case e ps ->
 103 >               d2c e                   `thenUs` \e' ->
 104 >               defCaseAlts2Core ps     `thenUs` \ps' ->
 105 >               returnUs (Case e' ps')
 106 >
 107 >       Let b e ->
 108 >               d2c e                   `thenUs` \e' ->
 109 >               defBinding2core b       `thenUs` \b' ->
 110 >               returnUs (Let b' e')
 111 >
 112 >       SCC l e ->
 113 >               d2c e                   `thenUs` \e' ->
 114 >               returnUs (SCC l e')
 115 >       Coerce _ _ _ ->
 116 >               panic "Def2Core:Coerce"
 117
 118 > defCaseAlts2Core :: DefCaseAlternatives
 119 >       -> UniqSM CoreCaseAlts
 120 >
 121 > defCaseAlts2Core alts = case alts of
 122 >       AlgAlts alts dflt ->
 123 >               mapUs algAlt2Core alts  `thenUs` \alts' ->
 124 >               defAlt2Core dflt        `thenUs` \dflt' ->
 125 >               returnUs (AlgAlts alts' dflt')
 126 >
 127 >       PrimAlts alts dflt ->
 128 >               mapUs primAlt2Core alts `thenUs` \alts' ->
 129 >               defAlt2Core dflt         `thenUs` \dflt' ->
 130 >               returnUs (PrimAlts alts' dflt')
 131 >
 132 >  where
 133 >
 134 >       algAlt2Core (c, vs, e)  = d2c e `thenUs` \e' -> returnUs (c, vs, e')
 135 >       primAlt2Core (l, e)     = d2c e `thenUs` \e' -> returnUs (l, e')
 136 >
 137 >       defAlt2Core NoDefault = returnUs NoDefault
 138 >       defAlt2Core (BindDefault v e) =
 139 >               d2c e `thenUs` \e' ->
 140 >               returnUs (BindDefault v e')
 141
 142 > mkLet :: CoreArg
 143 >       -> Maybe CoreExpr
 144 >       -> CoreExpr
 145 >       -> CoreExpr
 146 >
 147 > mkLet (VarArg v) (Just e) e' = Let (NonRec v e) e'
 148 > mkLet v Nothing  e' = e'
 149
 150 -----------------------------------------------------------------------------
 151 XXX - in here becuase if it goes in DefUtils we've got mutual recursion.
 152
 153 > defPanic :: String -> String -> DefExpr -> UniqSM a
 154 > defPanic modl fun expr =
 155 >       d2c expr        `thenUs` \expr ->
 156 >       panic (modl ++ "(" ++ fun ++ "): " ++ ppShow 80 (ppr PprDebug expr))