-
Notifications
You must be signed in to change notification settings - Fork 21
/
ApplyUnited.cag
119 lines (90 loc) · 4.31 KB
/
ApplyUnited.cag
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
%%[doesWhat doclatex
do not do \textit{APPLY} on variables that bind the result of a previous \textit{UNIT} of a P-node.
Instead, do a \textit{CALL} of the function if it is now saturated, or build a new P-node if it is undersaturated.
%%]
For each pattern
UNIT (#P/needs/f x y) ;\r ->
...
APPLY r a b
replace the APPLY expression by
CALL f x y a b if n==needs
UNIT (#P/m/f x y a b) if n< needs
where n = |a b|
m = needs - n
%%[(8 codegen grin) ag import({GrinCode/AbsSyn})
%%]
%%[(8 codegen grin) hs import (qualified Data.Map as Map, qualified Data.Set as Set)
%%]
%%[(8 codegen grin) hs import ({%{EH}Base.Common}, {%{EH}GrinCode.Common}, {%{EH}GrinCode}, {%{EH}Base.HsName} )
%%]
%%[(8 codegen grin) hs import({%{EH}Base.Debug})
%%]
%%[(8 codegen grin) hs import(EH.Util.Debug)
%%]
%%[(8 codegen grin)
WRAPPER GrAGItf
%%]
%%[(8 codegen grin) hs module {%{EH}GrinCode.Trf.ApplyUnited} export(applyUnited)
applyUnited :: GrModule -> Maybe GrModule
applyUnited grmod = let t = wrap_GrAGItf (sem_GrAGItf (GrAGItf_AGItf grmod))
(Inh_GrAGItf)
in if (changed_Syn_GrAGItf t)
then Just (grTrf_Syn_GrAGItf t)
else Nothing
%%]
%%[(8 codegen grin)
ATTR GrAGItf [ | | grTrf: GrModule ]
ATTR AllNT [ | | grTrf: SELF ]
%%]
%%[(8 codegen grin)
-- Environment passes information about variables that hold a P-node.
ATTR AllGrExpr [ env : {Map.Map HsName GrVal} | | ]
ATTR GrExpr [ | | mbUnitPNode : {Maybe GrVal} ]
ATTR GrPatLam [ | | getName : {HsName} ]
ATTR GrVal [ | | hasPAppTag : {Bool} ]
ATTR AllNT GrAGItf [ | | changed USE {||} {False} : {Bool} ]
SEM GrPatLam
| Var lhs.getName = @nm
| * - Var lhs.getName = error "ApplyUnited: getName from non-variable"
SEM GrVal
| Node lhs.hasPAppTag = isPAppTag @tag.grTrf
| * - Node lhs.hasPAppTag = False
SEM GrBind
| Bind expr.env = Map.empty
SEM GrExpr
| Seq body.env = maybe (--(const $ "did not insert expr = " ++ show @expr.grTrf) >>>
@lhs.env)
(\val -> --(const $ "\ninserting " ++ show @pat.getName ++ " with expr = " ++ show @expr.grTrf) >>>
Map.insert @pat.getName val @lhs.env)
(case @expr.grTrf of
GrExpr_Unit val@(GrVal_Node (GrTag_PApp _ _) _) -> Just val
_ -> Nothing
)
| Unit lhs.mbUnitPNode =
if @val.hasPAppTag
then --(const $ "found PTAGunit, val = " ++ show @val.grTrf) >>>
Just @val.grTrf
else --(const $ "found notPTAGunit, val = " ++ show @val.grTrf) >>>
Nothing
| * - Unit lhs.mbUnitPNode = Nothing
| App (lhs.grTrf,lhs.changed)
= --(const $ "\nfound apply, nm = " ++ show @nm) >>>
maybe (@loc.grTrf,False)
(\node -> (applyNode @nm @argL.grTrf node,True))
(Map.lookup @nm @lhs.env)
%%]
%%[(8 codegen grin) hs
applyNode nm2 flds2 node@(GrVal_Node (GrTag_PApp needs nm) flds1)
= --(const $ "\napplyNode " ++ show nm2 ++ "\nnode = " ++ show node) >>>
let n = length flds2
in if n<needs
then GrExpr_Unit (GrVal_Node (GrTag_PApp (needs-n) nm) (flds1++flds2))
else if n==needs
then GrExpr_Call nm (flds1++flds2)
else let newname = hsnFromString "hallo"
flds2a = take needs flds2
flds2b = drop needs flds2
in GrExpr_Seq (GrExpr_Call nm (flds1++flds2a))
(GrPatLam_Var newname)
(GrExpr_App newname flds2b)
%%]