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