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