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(..), SYN_IE(UniqSM),
13 > GenCoreBinding, Id, DefBindee,
26 > def2core :: DefProgram -> UniqSM [CoreBinding]
27 > def2core prog = mapUs defBinding2core prog
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' ->
36 > where recBind2core (v,e)
37 > = d2c e `thenUs` \e' ->
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 _ _)"
56 > d2c :: DefExpr -> UniqSM CoreExpr
59 > Var (DefArgExpr e) ->
60 > panic "Def2Core(d2c): Var (DefArgExpr _)"
63 > panic "Def2Core(d2c): Var (Label _ _)"
65 > Var (DefArgVar v) ->
72 > mapUs defAtom2core as `thenUs` \atom_expr_pairs ->
74 > foldr (\(a,b) -> mkLet a b)
75 > (Con c ts (map fst atom_expr_pairs))
79 > mapUs defAtom2core as `thenUs` \atom_expr_pairs ->
81 > foldr (\(a,b) -> mkLet a b)
82 > (Prim op ts (map fst atom_expr_pairs))
86 > d2c e `thenUs` \e' ->
87 > returnUs (Lam vs e')
90 > d2c e `thenUs` \e' ->
91 > returnUs (CoTyLam alpha e')
94 > d2c e `thenUs` \e' ->
95 > defAtom2core v `thenUs` \(v',e'') ->
96 > returnUs (mkLet v' e'' (App e' v'))
99 > d2c e `thenUs` \e' ->
100 > returnUs (CoTyApp e' t)
103 > d2c e `thenUs` \e' ->
104 > defCaseAlts2Core ps `thenUs` \ps' ->
105 > returnUs (Case e' ps')
108 > d2c e `thenUs` \e' ->
109 > defBinding2core b `thenUs` \b' ->
110 > returnUs (Let b' e')
113 > d2c e `thenUs` \e' ->
114 > returnUs (SCC l e')
116 > panic "Def2Core:Coerce"
118 > defCaseAlts2Core :: DefCaseAlternatives
119 > -> UniqSM CoreCaseAlts
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')
127 > PrimAlts alts dflt ->
128 > mapUs primAlt2Core alts `thenUs` \alts' ->
129 > defAlt2Core dflt `thenUs` \dflt' ->
130 > returnUs (PrimAlts alts' dflt')
134 > algAlt2Core (c, vs, e) = d2c e `thenUs` \e' -> returnUs (c, vs, e')
135 > primAlt2Core (l, e) = d2c e `thenUs` \e' -> returnUs (l, e')
137 > defAlt2Core NoDefault = returnUs NoDefault
138 > defAlt2Core (BindDefault v e) =
139 > d2c e `thenUs` \e' ->
140 > returnUs (BindDefault v e')
147 > mkLet (VarArg v) (Just e) e' = Let (NonRec 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 -> UniqSM a
154 > defPanic modl fun expr =
155 > d2c expr `thenUs` \expr ->
156 > panic (modl ++ "(" ++ fun ++ "): " ++ ppShow 80 (ppr PprDebug expr))