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(..), SUniqSM(..), PlainCoreProgram(..),
  13 >       CoreBinding, Id, DefBindee,
  14 >       defPanic
  15 >       ) where
  16
  17 > import DefSyn
  18 > import DefUtils
  19 >
  20 > import Maybes         ( Maybe(..) )
  21 > import Outputable
  22 > import PlainCore
  23 > import Pretty
  24 > import SplitUniq
  25 > import Util
  26
  27
  28 > def2core :: DefProgram -> SUniqSM PlainCoreProgram
  29 > def2core prog = mapSUs defBinding2core prog
  30
  31 > defBinding2core :: DefBinding -> SUniqSM PlainCoreBinding
  32 > defBinding2core (CoNonRec v e) =
  33 >       d2c e `thenSUs` \e' ->
  34 >       returnSUs (CoNonRec v e')
  35 > defBinding2core (CoRec bs) =
  36 >       mapSUs recBind2core bs `thenSUs` \bs' ->
  37 >       returnSUs (CoRec bs')
  38 >               where recBind2core (v,e)
  39 >                       = d2c e `thenSUs` \e' ->
  40 >                         returnSUs (v, e')
  41
  42
  43 > defAtom2core :: DefAtom -> SUniqSM (PlainCoreAtom, Maybe PlainCoreExpr)
  44 > defAtom2core atom = case atom of
  45 >       CoLitAtom l -> returnSUs (CoLitAtom l, Nothing)
  46 >       CoVarAtom (DefArgVar id) -> returnSUs (CoVarAtom id, Nothing)
  47 >       CoVarAtom (DefArgExpr (CoVar (DefArgVar id))) ->
  48 >               returnSUs (CoVarAtom id, Nothing)
  49 >       CoVarAtom (DefArgExpr (CoLit l)) ->
  50 >               returnSUs (CoLitAtom l, Nothing)
  51 >       CoVarAtom (DefArgExpr e) ->
  52 >               d2c e           `thenSUs` \e' ->
  53 >               newTmpId (typeOfCoreExpr e')    `thenSUs` \new_id ->
  54 >               returnSUs (CoVarAtom new_id, Just e')
  55 >       CoVarAtom (Label _ _) ->
  56 >               panic "Def2Core(defAtom2core): CoVarAtom (Label _ _)"
  57
  58 > d2c :: DefExpr -> SUniqSM PlainCoreExpr
  59 > d2c e = case e of
  60 >
  61 >       CoVar (DefArgExpr e) ->
  62 >               panic "Def2Core(d2c): CoVar (DefArgExpr _)"
  63 >
  64 >       CoVar (Label _ _) ->
  65 >               panic "Def2Core(d2c): CoVar (Label _ _)"
  66 >
  67 >       CoVar (DefArgVar v) ->
  68 >               returnSUs (CoVar v)
  69 >
  70 >       CoLit l ->
  71 >               returnSUs (CoLit l)
  72 >
  73 >       CoCon c ts as ->
  74 >               mapSUs defAtom2core as  `thenSUs` \atom_expr_pairs ->
  75 >               returnSUs (
  76 >                       foldr (\(a,b) -> mkLet a b)
  77 >                               (CoCon c ts (map fst atom_expr_pairs))
  78 >                               atom_expr_pairs)
  79 >
  80 >       CoPrim op ts as ->
  81 >               mapSUs defAtom2core as  `thenSUs` \atom_expr_pairs ->
  82 >               returnSUs (
  83 >                       foldr (\(a,b) -> mkLet a b)
  84 >                               (CoPrim op ts (map fst atom_expr_pairs))
  85 >                               atom_expr_pairs)
  86 >
  87 >       CoLam vs e ->
  88 >               d2c e                   `thenSUs` \e' ->
  89 >               returnSUs (CoLam vs e')
  90 >
  91 >       CoTyLam alpha e ->
  92 >               d2c e                   `thenSUs` \e' ->
  93 >               returnSUs (CoTyLam alpha e')
  94 >
  95 >       CoApp e v       ->
  96 >               d2c e                   `thenSUs` \e' ->
  97 >               defAtom2core v          `thenSUs` \(v',e'') ->
  98 >               returnSUs (mkLet v' e'' (CoApp e' v'))
  99 >
 100 >       CoTyApp e t     ->
 101 >               d2c e                   `thenSUs` \e' ->
 102 >               returnSUs (CoTyApp e' t)
 103 >
 104 >       CoCase e ps ->
 105 >               d2c e                   `thenSUs` \e' ->
 106 >               defCaseAlts2Core ps     `thenSUs` \ps' ->
 107 >               returnSUs (CoCase e' ps')
 108 >
 109 >       CoLet b e ->
 110 >               d2c e                   `thenSUs` \e' ->
 111 >               defBinding2core b       `thenSUs` \b' ->
 112 >               returnSUs (CoLet b' e')
 113 >
 114 >       CoSCC l e ->
 115 >               d2c e                   `thenSUs` \e' ->
 116 >               returnSUs (CoSCC l e')
 117
 118 > defCaseAlts2Core :: DefCaseAlternatives
 119 >       -> SUniqSM PlainCoreCaseAlternatives
 120 >
 121 > defCaseAlts2Core alts = case alts of
 122 >       CoAlgAlts alts dflt ->
 123 >               mapSUs algAlt2Core alts `thenSUs` \alts' ->
 124 >               defAlt2Core dflt        `thenSUs` \dflt' ->
 125 >               returnSUs (CoAlgAlts alts' dflt')
 126 >
 127 >       CoPrimAlts alts dflt ->
 128 >               mapSUs primAlt2Core alts `thenSUs` \alts' ->
 129 >               defAlt2Core dflt         `thenSUs` \dflt' ->
 130 >               returnSUs (CoPrimAlts alts' dflt')
 131 >
 132 >  where
 133 >
 134 >       algAlt2Core (c, vs, e)  = d2c e `thenSUs` \e' -> returnSUs (c, vs, e')
 135 >       primAlt2Core (l, e)     = d2c e `thenSUs` \e' -> returnSUs (l, e')
 136 >
 137 >       defAlt2Core CoNoDefault = returnSUs CoNoDefault
 138 >       defAlt2Core (CoBindDefault v e) =
 139 >               d2c e `thenSUs` \e' ->
 140 >               returnSUs (CoBindDefault v e')
 141
 142 > mkLet :: PlainCoreAtom
 143 >       -> Maybe PlainCoreExpr
 144 >       -> PlainCoreExpr
 145 >       -> PlainCoreExpr
 146 >
 147 > mkLet (CoVarAtom v) (Just e) e' = CoLet (CoNonRec 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 -> SUniqSM a
 154 > defPanic modl fun expr =
 155 >       d2c expr        `thenSUs` \expr ->
 156 >       panic (modl ++ "(" ++ fun ++ "): " ++ ppShow 80 (ppr PprDebug expr))