|
|
1
|
+{-
|
|
|
2
|
+(c) The University of Glasgow 2006
|
|
|
3
|
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
|
|
|
4
|
+-}
|
|
|
5
|
+
|
|
|
6
|
+module GHC.Core.SubstTypeLets(
|
|
|
7
|
+ substTypeLets
|
|
|
8
|
+ ) where
|
|
|
9
|
+
|
|
|
10
|
+import GHC.Prelude
|
|
|
11
|
+
|
|
|
12
|
+import GHC.Core
|
|
|
13
|
+import GHC.Core.Subst
|
|
|
14
|
+import GHC.Core.Utils( mkInScopeSetBndrs )
|
|
|
15
|
+
|
|
|
16
|
+import GHC.Types.Var
|
|
|
17
|
+
|
|
|
18
|
+import GHC.Utils.Misc( mapSnd )
|
|
|
19
|
+import GHC.Utils.Outputable
|
|
|
20
|
+import GHC.Utils.Panic
|
|
|
21
|
+
|
|
|
22
|
+{- Note [Substituting type-lets]
|
|
|
23
|
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
24
|
+ToDo: write me
|
|
|
25
|
+
|
|
|
26
|
+NB: only substitutes /nested/ type-lets, not top level.
|
|
|
27
|
+-}
|
|
|
28
|
+
|
|
|
29
|
+substTypeLets :: CoreProgram -> CoreProgram
|
|
|
30
|
+substTypeLets binds = map stl_top binds
|
|
|
31
|
+ where
|
|
|
32
|
+ stl_top (NonRec b r) = NonRec b (stlExpr empty_subst r)
|
|
|
33
|
+ stl_top (Rec prs) = Rec (mapSnd (stlExpr empty_subst) prs)
|
|
|
34
|
+
|
|
|
35
|
+ empty_subst = mkEmptySubst $
|
|
|
36
|
+ mkInScopeSetBndrs binds
|
|
|
37
|
+
|
|
|
38
|
+----------------------
|
|
|
39
|
+stlBind :: Subst -> CoreBind -> (Subst, CoreBind)
|
|
|
40
|
+stlBind subst (Rec prs)
|
|
|
41
|
+ = assertPpr (not (any isTyVar bndrs)) (ppr prs) $
|
|
|
42
|
+ (subst', Rec prs')
|
|
|
43
|
+ where
|
|
|
44
|
+ (bndrs,rhss) = unzip prs
|
|
|
45
|
+ (subst', bndrs') = substBndrs subst bndrs
|
|
|
46
|
+ rhss' = map (stlExpr subst') rhss
|
|
|
47
|
+ prs' = bndrs' `zip` rhss'
|
|
|
48
|
+
|
|
|
49
|
+stlBind subst (NonRec bndr rhs)
|
|
|
50
|
+ = (subst', NonRec bndr' (stlExpr subst rhs))
|
|
|
51
|
+ where
|
|
|
52
|
+ (subst', bndr') = substBndr subst bndr
|
|
|
53
|
+
|
|
|
54
|
+----------------------
|
|
|
55
|
+stlExpr :: Subst -> CoreExpr -> CoreExpr
|
|
|
56
|
+
|
|
|
57
|
+-- This case is the main payload of the entire pass
|
|
|
58
|
+stlExpr subst (Let (NonRec tv (Type ty)) body)
|
|
|
59
|
+ = stlExpr (extendTvSubst subst tv ty) body
|
|
|
60
|
+
|
|
|
61
|
+stlExpr subst (Let bind body)
|
|
|
62
|
+ = Let bind' (stlExpr subst' body)
|
|
|
63
|
+ where
|
|
|
64
|
+ (subst', bind') = stlBind subst bind
|
|
|
65
|
+
|
|
|
66
|
+stlExpr subst (Lam bndr body)
|
|
|
67
|
+ = Lam bndr' (stlExpr subst' body)
|
|
|
68
|
+ where
|
|
|
69
|
+ (subst', bndr') = substBndr subst bndr
|
|
|
70
|
+
|
|
|
71
|
+stlExpr subst (Case scrut bndr ty alts)
|
|
|
72
|
+ = Case (stlExpr subst scrut) bndr' (substTy subst ty)
|
|
|
73
|
+ (map stl_alt alts)
|
|
|
74
|
+ where
|
|
|
75
|
+ (subst', bndr') = substBndr subst bndr
|
|
|
76
|
+
|
|
|
77
|
+ stl_alt (Alt con bndrs rhs)
|
|
|
78
|
+ = Alt con bndrs' (stlExpr subst'' rhs)
|
|
|
79
|
+ where
|
|
|
80
|
+ (subst'', bndrs') = substBndrs subst' bndrs
|
|
|
81
|
+
|
|
|
82
|
+-- Simple cases
|
|
|
83
|
+stlExpr _ (Lit l) = Lit l
|
|
|
84
|
+stlExpr subst (Var v) = lookupIdSubst subst v
|
|
|
85
|
+stlExpr subst (App e1 e2) = App (stlExpr subst e1) (stlExpr subst e2)
|
|
|
86
|
+stlExpr subst (Type ty) = Type (substTy subst ty)
|
|
|
87
|
+stlExpr subst (Tick t e) = Tick (substTickish subst t) (stlExpr subst e)
|
|
|
88
|
+stlExpr subst (Cast e co) = Cast (stlExpr subst e) (substCo subst co)
|
|
|
89
|
+stlExpr subst (Coercion co) = Coercion (substCo subst co) |