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(..), UniqSM(..),
13 > GenCoreBinding, Id, DefBindee,
20 > import Maybes ( Maybe(..) )
27 > def2core :: DefProgram -> UniqSM [CoreBinding]
28 > def2core prog = mapUs defBinding2core prog
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' ->
37 > where recBind2core (v,e)
38 > = d2c e `thenUs` \e' ->
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 _ _)"
57 > d2c :: DefExpr -> UniqSM CoreExpr
60 > Var (DefArgExpr e) ->
61 > panic "Def2Core(d2c): Var (DefArgExpr _)"
64 > panic "Def2Core(d2c): Var (Label _ _)"
66 > Var (DefArgVar v) ->
73 > mapUs defAtom2core as `thenUs` \atom_expr_pairs ->
75 > foldr (\(a,b) -> mkLet a b)
76 > (Con c ts (map fst atom_expr_pairs))
80 > mapUs defAtom2core as `thenUs` \atom_expr_pairs ->
82 > foldr (\(a,b) -> mkLet a b)
83 > (Prim op ts (map fst atom_expr_pairs))
87 > d2c e `thenUs` \e' ->
88 > returnUs (Lam vs e')
91 > d2c e `thenUs` \e' ->
92 > returnUs (CoTyLam alpha e')
95 > d2c e `thenUs` \e' ->
96 > defAtom2core v `thenUs` \(v',e'') ->
97 > returnUs (mkLet v' e'' (App e' v'))
100 > d2c e `thenUs` \e' ->
101 > returnUs (CoTyApp e' t)
104 > d2c e `thenUs` \e' ->
105 > defCaseAlts2Core ps `thenUs` \ps' ->
106 > returnUs (Case e' ps')
109 > d2c e `thenUs` \e' ->
110 > defBinding2core b `thenUs` \b' ->
111 > returnUs (Let b' e')
114 > d2c e `thenUs` \e' ->
115 > returnUs (SCC l e')
117 > defCaseAlts2Core :: DefCaseAlternatives
118 > -> UniqSM CoreCaseAlts
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')
126 > PrimAlts alts dflt ->
127 > mapUs primAlt2Core alts `thenUs` \alts' ->
128 > defAlt2Core dflt `thenUs` \dflt' ->
129 > returnUs (PrimAlts alts' dflt')
133 > algAlt2Core (c, vs, e) = d2c e `thenUs` \e' -> returnUs (c, vs, e')
134 > primAlt2Core (l, e) = d2c e `thenUs` \e' -> returnUs (l, e')
136 > defAlt2Core NoDefault = returnUs NoDefault
137 > defAlt2Core (BindDefault v e) =
138 > d2c e `thenUs` \e' ->
139 > returnUs (BindDefault v e')
146 > mkLet (VarArg v) (Just e) e' = Let (NonRec v e) e'
147 > mkLet v Nothing e' = e'
149 -----------------------------------------------------------------------------
150 XXX - in here becuase if it goes in DefUtils we've got mutual recursion.
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))