2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[Def2Core]{Translate a DefProgram back into a CoreProgram}
6 >#include "HsVersions.h"
11 > -- and to make the interface self-sufficient, all this stuff:
12 > DefBinding(..), SUniqSM(..), PlainCoreProgram(..),
13 > CoreBinding, Id, DefBindee,
20 > import Maybes ( Maybe(..) )
28 > def2core :: DefProgram -> SUniqSM PlainCoreProgram
29 > def2core prog = mapSUs defBinding2core prog
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' ->
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 _ _)"
58 > d2c :: DefExpr -> SUniqSM PlainCoreExpr
61 > CoVar (DefArgExpr e) ->
62 > panic "Def2Core(d2c): CoVar (DefArgExpr _)"
64 > CoVar (Label _ _) ->
65 > panic "Def2Core(d2c): CoVar (Label _ _)"
67 > CoVar (DefArgVar v) ->
74 > mapSUs defAtom2core as `thenSUs` \atom_expr_pairs ->
76 > foldr (\(a,b) -> mkLet a b)
77 > (CoCon c ts (map fst atom_expr_pairs))
81 > mapSUs defAtom2core as `thenSUs` \atom_expr_pairs ->
83 > foldr (\(a,b) -> mkLet a b)
84 > (CoPrim op ts (map fst atom_expr_pairs))
88 > d2c e `thenSUs` \e' ->
89 > returnSUs (CoLam vs e')
92 > d2c e `thenSUs` \e' ->
93 > returnSUs (CoTyLam alpha e')
96 > d2c e `thenSUs` \e' ->
97 > defAtom2core v `thenSUs` \(v',e'') ->
98 > returnSUs (mkLet v' e'' (CoApp e' v'))
101 > d2c e `thenSUs` \e' ->
102 > returnSUs (CoTyApp e' t)
105 > d2c e `thenSUs` \e' ->
106 > defCaseAlts2Core ps `thenSUs` \ps' ->
107 > returnSUs (CoCase e' ps')
110 > d2c e `thenSUs` \e' ->
111 > defBinding2core b `thenSUs` \b' ->
112 > returnSUs (CoLet b' e')
115 > d2c e `thenSUs` \e' ->
116 > returnSUs (CoSCC l e')
118 > defCaseAlts2Core :: DefCaseAlternatives
119 > -> SUniqSM PlainCoreCaseAlternatives
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')
127 > CoPrimAlts alts dflt ->
128 > mapSUs primAlt2Core alts `thenSUs` \alts' ->
129 > defAlt2Core dflt `thenSUs` \dflt' ->
130 > returnSUs (CoPrimAlts alts' dflt')
134 > algAlt2Core (c, vs, e) = d2c e `thenSUs` \e' -> returnSUs (c, vs, e')
135 > primAlt2Core (l, e) = d2c e `thenSUs` \e' -> returnSUs (l, e')
137 > defAlt2Core CoNoDefault = returnSUs CoNoDefault
138 > defAlt2Core (CoBindDefault v e) =
139 > d2c e `thenSUs` \e' ->
140 > returnSUs (CoBindDefault v e')
142 > mkLet :: PlainCoreAtom
143 > -> Maybe PlainCoreExpr
147 > mkLet (CoVarAtom v) (Just e) e' = CoLet (CoNonRec v e) e'
148 > mkLet v Nothing e' = e'
150 -----------------------------------------------------------------------------
151 XXX - in here becuase if it goes in DefUtils we've got mutual recursion.
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))