fusion.ml 3.69 KB
Newer Older
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
1
#
2
# procedure fuse-bodies takes a sem_stmt_list and returns a sem_stmt_list
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
3
4
5
6
7
8
9
10
11
12
13
14
15
# with fused bodies of conditions.
#
# most simple implementation
#
#	val fuse-bodies stmts = return stmts
#
# simple example:
#
#   if a then b else c;
#   if a then d else e;
#
#   --> if a then do b; d; end else do c; e; end
#
16
17
18
19
20
21
22
23
24

# do a fusion of ITEs on a list of statements
#
# Parameter:
#    list of statements
# 
# Returns:
#    list of statements with inlined right hand sides
#
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
25
26
27
28
29
30
31
export fuse-bodies : (sem_stmt_list)-> S sem_stmt_list <{} => {}>
val fuse-bodies stmts = fuse-bodies-stmt-list-initial stmts

val fuse-bodies-stmt-list-initial stmts = return (fuse-bodies-stmt-list stmts)

val fuse-bodies-stmt-list stmts = case stmts of
	  SEM_CONS s : case s.hd of
32
	  	  SEM_ITE t : do
33
			fusable <- return (SEM_CONS {hd=s.hd, tl=SEM_NIL});
34
			fusable <- return (get-fusable t.cond fusable stmts);
35
			head <- return (fuse-bodies-ite-list s.hd fusable);
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
36
37
38
			tail <- return (get-remainder fusable stmts);
			continued <- return (fuse-bodies-stmt-list tail);
			return (SEM_CONS {hd=head, tl=continued})
39
40
		  end
		| _		  : do
41
			continued <- return (fuse-bodies-stmt-list s.tl);
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
42
			return (SEM_CONS {hd=s.hd, tl=continued})
43
		  end
44
	  end
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
45
46
47
48
49
	| SEM_NIL    : return SEM_NIL
end

val get-fusable c fusable stmts = case stmts of
	  SEM_CONS s : case s.hd of
50
	  	  SEM_ITE t : if (equal t.cond c) then get-fusable c (append fusable (SEM_CONS {hd=s.hd, tl=SEM_NIL})) s.tl else fusable
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
51
		| _			: fusable
52
	  end
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
53
54
55
56
57
58
	| SEM_NIL    : fusable
end

val fuse-bodies-ite-list head tail = case tail of
	  SEM_CONS tt : case tt.hd of
		SEM_ITE t : case head of
59
			SEM_ITE h : fuse-bodies-ite-list (SEM_ITE {cond=h.cond,
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
60
61
62
													   then_branch=(append h.then_branch t.then_branch),
													   else_branch=(append h.else_branch t.else_branch)}) tt.tl
		end
63
	  end
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
64
65
66
67
68
69
70
71
72
73
74
75
76
77
	| SEM_NIL	  : head
end

val get-remainder fusable stmts = case fusable of
	  SEM_CONS f : case stmts of
	  	  SEM_CONS s : get-remainder f.tl s.tl
		| SEM_NIL    : stmts
	  end
	| SEM_NIL	 : stmts
end

val append a b = case a of
	  SEM_CONS s : case b of
	  	  SEM_CONS t : case s.tl of
78
		  	  SEM_CONS u : SEM_CONS {hd=s.hd, tl=(append s.tl b)}
79
			| SEM_NIL	 : SEM_CONS {hd=s.hd, tl=b}
80
		  end
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
81
		| SEM_NIL	 : a
82
	  end
Lovis J.I. Zenz's avatar
Lovis J.I. Zenz committed
83
	| SEM_NIL	 : b
84
85
86
end

val equal a b = case a of
87
88
89
	  SEM_SEXPR_LIN l  : case b of
	  	  SEM_SEXPR_LIN ll : lin-eq? l ll
		| _				   : '0'
90
	  end
91
	| SEM_SEXPR_CMP cm : case b of
92
		  SEM_SEXPR_CMP cmcm : if cmp-eq? cm.cmp cmcm.cmp then cm.size === cmcm.size else '0'
93
		| _					 : '0'
94
95
96
97
98
	  end
	| SEM_SEXPR_ARB    : case b of
		  SEM_SEXPR_ARB : '1'
		| _				: '0'
	  end
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
end

val cmp-eq? cmp1 cmp2 = case cmp1 of
	  SEM_CMPEQ a  : case cmp2 of
	  	  SEM_CMPEQ b : if lin-eq? a.opnd1 b.opnd1 then lin-eq? a.opnd2 b.opnd2 else '0' 
		| _			  : '0'
	  end
	| SEM_CMPNEQ a : case cmp2 of
	  	  SEM_CMPNEQ b : if lin-eq? a.opnd1 b.opnd1 then lin-eq? a.opnd2 b.opnd2 else '0'
		| _			   : '0'
	  end
	| SEM_CMPLES a : case cmp2 of
	  	  SEM_CMPLES b : if lin-eq? a.opnd1 b.opnd1 then lin-eq? a.opnd2 b.opnd2 else '0'
		| _			   : '0'
	  end
	| SEM_CMPLEU a : case cmp2 of
	  	  SEM_CMPLEU b : if lin-eq? a.opnd1 b.opnd1 then lin-eq? a.opnd2 b.opnd2 else '0'
		| _			   : '0'
	  end
	| SEM_CMPLTS a : case cmp2 of
	  	  SEM_CMPLTS b : if lin-eq? a.opnd1 b.opnd1 then lin-eq? a.opnd2 b.opnd2 else '0'
		| _			   : '0'
	  end
	| SEM_CMPLTU a :case cmp2 of
	  	  SEM_CMPLTU b : if lin-eq? a.opnd1 b.opnd1 then lin-eq? a.opnd2 b.opnd2 else '0'
		| _			   : '0'
	  end
end

val lin-eq? lin1 lin2 = case lin1 of
	  SEM_LIN_VAR v : case lin2 of
	  	  SEM_LIN_VAR vv : if id-eq? v.id vv.id then v.offset === vv.offset else '0'
		| _				 : '0'
	  end
	| SEM_LIN_IMM i : case lin2 of
	  	  SEM_LIN_IMM ii : i.const === ii.const
		| _				 : '0'
	  end
137
end