/pliant/language/optimizer/extra.pli
1	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
2	#
3	# This program is free software; you can redistribute it and/or
4	# modify it under the terms of the GNU General Public License version 2
5	# as published by the Free Software Foundation.
6	#
7	# This program is distributed in the hope that it will be useful,
8	# but WITHOUT ANY WARRANTY; without even the implied warranty of
9	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
10	# GNU General Public License for more details.
11	#
12	# You should have received a copy of the GNU General Public License
13	# version 2 along with this program; if not, write to the Free Software
14	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
15
16	scope "/pliant/language/" "/pliant/install/"
17	module "/pliant/install/ring2.pli"
18
19
20	gvar CBool active := false
21
22	function optimize_constant_instruction i gc -> i2
23	arg_rw Instruction i ;  arg_rw GeneratorContext gc ; arg_RW Instruction i2
24	i2 :> i
25	var Pointer:Function f :> i function
26	if ('.and.' f:flags function_flag_has_side_effects)<>0
27	return
28	if ('.and.' f:flags function_flag_later)<>0
29	return
30	if ('.and.' f:flags function_flag_under_construction)<>0
31	return
32	if f:nb_args=0 or f:nb_args_with_result=f:nb_args
33	return
34	for (var Int u) 0 f:nb_args-1
35	if i:u:where<>argument_constant
36	return
37	for (var Int u) 0 f:nb_args
38	if (f may_map u) or i:u:type:real_data_type<>i:u:type
39	return
40	if i:(f:nb_args):where<>argument_local or ('.and.' (f arg f:nb_args):access access_mapped)<>0
41	return
42	var Link:Type t :> i:(f:nb_args) type
43	if t<>t:real_data_type
44	return
45	if (addressof i:jump)<>null
46	return
47	if ('.and.' f:flags function_flag_copy)<>0
48	return
49	var Link:Expression e :> new Expression
50	e module :> gc module
51	var Link:Instruction i3 :> new Instruction
52	i3 function :> i function
53	i3 'size :=' i:size
54	for (var Int u) 0 f:nb_args-1
55	var Link:Argument a :> new Argument ; a locate i:u:type argument_constant ; a constant := i:u constant
56	i3 u :> a
57	var Link:Argument a :> argument local t
58	i3 f:nb_args :> a
59	e add i3
60	e set_result a access_read
61	active := true
62	var Address cst := e evaluate t function_flag_implicit+function_flag_extension+function_flag_reduction
63	active := false
64	if cst=null
65	return
66	var Link:Argument a :> new Argument ; a locate t argument_constant ; a constant := cst
67	i2 :> instruction (the_function 'copy Universal' Universal Universal Type) a i:(f:nb_args) (argument mapped_constant Type t)
68	gc insert_after_instruction i i2
69	gc remove i
70
71	function optimize_constant gc
72	arg_rw GeneratorContext gc
73	if active
74	return
75	var Link:Instruction i :> gc first_instruction
76	while addressof:i<>null
77	i :> (optimize_constant_instruction i gc) next_instruction
78
79
80
81
82
83	function copy_int8 src dest
84	arg Int src ; arg_w Int dest
85	gcc_inline "*(char *)@2 = (char)$1;"
86
87	function copy_int16 src dest
88	arg Int src ; arg_w Int dest
89	gcc_inline "*(short *)@2 = (short)$1;"
90
91	function optimize_copy gc
92	arg_rw GeneratorContext gc
93	var Pointer:Instruction instr :> gc first_instruction
94	while addressof:instr<>null
95	if (addressof instr:function)=addressof:(the_function 'copy scalar' Universal Universal Int)
96	var Pointer:Argument targ :> instr 2 ; check targ:where=argument_constant and (entry_type targ:constant)=Int
97	var Int size := instr:2:constant map Int
98	if size=0
99	instr :> gc remove instr
100	eif size=1
101	if gcc_is_active
102	gc insert_after_instruction instr (instruction (the_function copy_int8 Int Int) instr:0 instr:1)
103	instr :> gc remove instr
104	eif processor_name="i386"
105	var Link:Argument arg :> argument a_register
106	var Pointer:Instruction cur :> gc insert_after_instruction instr (instruction (the_function i386_movzx8 Int -> Int) instr:0 arg)
107	gc insert_after_instruction cur (instruction (the_function i386_mov8 Int -> Int) arg instr:1)
108	instr :> gc remove instr
109	eif processor_name="i386" and size=2
110	if gcc_is_active
111	gc insert_after_instruction instr (instruction (the_function copy_int16 Int Int) instr:0 instr:1)
112	instr :> gc remove instr
113	else
114	var Link:Argument arg :> argument a_register
115	var Pointer:Instruction cur :> gc insert_after_instruction instr (instruction (the_function i386_movzx16 Int -> Int) instr:0 arg)
116	gc insert_after_instruction cur (instruction (the_function i386_mov16 Int -> Int) arg instr:1)
117	instr :> gc remove instr
118	eif size=Int:size
119	gc insert_after_instruction instr (instruction (the_function 'copy atomic' Int Int) instr:0 instr:1)
120	instr :> gc remove instr
121	else
122	instr :> instr next_instruction
123	else
124	instr :> instr next_instruction
125
126
127
128
129
130	function optimize_translate gc
131	arg_rw GeneratorContext gc
132	var Link:Instruction i :> gc first_instruction
133	while addressof:i<>null
134	var Link:Instruction i2 :> null map Instruction
135	var Pointer:Function f :> i function
136	if f=(the_function 'translate Universal' Universal Int -> Universal)
137	if i:0:where=argument_indirect and i:0:offset=0
138	if i:1:where=argument_constant and (i:1:constant map Int)=0
139	i2 :> instruction (the_function 'copy atomic' Int Int) i:0:pointer i:2
140	else
141	i2 :> instruction (the_function '+' Int Int -> Int) i:0:pointer i:1 i:2
142	gc keep_object i:0
143	else
144	if i:1:where=argument_constant and (i:1:constant map Int)=0
145	i2 :> instruction (the_function 'address Universal' Universal -> Address) i:0 i:2
146	eif f=(the_function 'address Universal' Universal -> Address)
147	if i:0:where=argument_indirect and i:0:offset=0
148	i2 :> instruction (the_function 'copy atomic' Int Int) i:0:pointer i:1
149	gc keep_object i:0
150	if addressof:i2<>null
151	gc insert_after_instruction i i2
152	gc remove i
153	i :> i2
154	i :> i next_instruction
155
156
157
158
159
160	constant standard_algo false
161	constant new_algo true
162	constant nonatomic_also true
163	constant indirect_also false
164
165	constant undefined_mapping ((the_function '+' Int Int -> Int) arg 0):maps
166
167	function optimize_drop gc
168	arg_rw GeneratorContext gc
169	gc share_begin
170	var Pointer:Arrow c :> gc:arguments first
171	while c<>null
172	var Link:Argument a :> c map Argument
173	if a:is_temporary and (nonatomic_also or ('.and.' a:type:flags type_flag_atomic)<>0)
174	var Link:Instruction first :> a first_instruction
175	var Link:Instruction last :> a last_instruction
176	if addressof:first<>null and (gcc_inline_instructions query addressof:first null)=null and (gcc_inline_instructions query addressof:last null)=null
177	if standard_algo
178	if ('.and.' first:function:flags function_flag_copy)<>0 and first:1=a
179	if (first:0 is_stable first last) and (indirect_also or first:0:where<>argument_indirect)
180	gc share_try a first:0
181	eif ('.and.' last:function:flags function_flag_copy)<>0 and last:0=a
182	if (last:1 is_stable first last) and (indirect_also or last:1:where<>argument_indirect)
183	gc share_try a last:1
184	if new_algo
185	if ('.and.' first:function:flags function_flag_copy)<>0 and first:1=a
186	if (first:0 is_stable first last) and (indirect_also or first:0:where<>argument_indirect)
187	if not (gc share_clash a first:0)
188	gc suckup a first:0
189	eif ('.and.' last:function:flags function_flag_copy)<>0 and last:0=a
190	if (last:1 is_stable first last) and (indirect_also or last:1:where<>argument_indirect)
191	if not (gc share_clash a last:1)
192	var Int i := 0
193	while i<first:size and first:i<>a
194	i := i+1
195	if i<first:size and ('.and.' (first:function arg i):maps '.not.':undefined_mapping)=0
196	gc suckup a last:1
197	c :> gc:arguments next c
198	gc share_end
199
200
201	record_optimizer_function optimize_constant "pliant optimizer rewrite instructions0"
202	record_optimizer_function optimize_copy "pliant optimizer rewrite instructions"
203	record_optimizer_function optimize_translate "pliant optimizer rewrite instructions"
204	record_optimizer_function optimize_drop "pliant optimizer rewrite instructions"
205	record_optimizer_function optimize_drop "pliant optimizer rewrite instructions2"