/pliant/language/compiler/expression/freeze.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/ring3.pli"
18
19
20	gvar Int freeze_counter := 0
21
22
23	method e uses a -> answer
24	arg Expression e ; arg Argument a ; arg CBool answer
25	var Pointer:Arrow c :> e:instructions first
26	while c<>null
27	var Pointer:Instruction instr :> c map Instruction
28	for (var Int i) 0 instr:size-1
29	var Pointer:Argument arg :> instr i
30	if addressof:arg=addressof:a
31	return true
32	while arg:where=argument_indirect
33	var Pointer:Argument arg :> arg pointer
34	if addressof:arg=addressof:a
35	return true
36	c :> e:instructions next c
37	answer := false
38
39	method final freeze expressions byaddress functions type
40	arg_rw Expression final ; arg_rw List expressions byaddress ; arg_rw List functions ; arg_rw Link:Type type
41	var Pointer:Module module :> final module
42	var Address mark := module mark
43	var Pointer:Arrow c :> pliant_general_dictionary first "pliant locals"
44	var Link:List external_locals
45	if c=null
46	external_locals :> new List
47	module define "pliant locals" addressof:external_locals
48	else
49	check (addressof entry_type:c)=addressof:List
50	external_locals :> c map List
51	var List instructions instructions2
52	type :> new Type
53	freeze_counter := freeze_counter+1
54	type name := "(Freeze "+string:freeze_counter+")"
55	type position := final position
56	var Link:Argument newadr :> argument local Address
57	var Link:Argument newobj :> argument indirect type newadr 0
58	instructions append addressof:(instruction (the_function entry_new Type -> Address) (argument mapped_constant Type type) newadr)
59	var Pointer:Arrow r :> expressions first
60	while r<>null
61	check (addressof entry_type:r)=addressof:Expression
62	var Pointer:Expression e :> r map Expression
63	var Link:Function fun :> new Function
64	var Link:Array arguments :> new Array
65	arguments 'size :=' 1
66	module define "pliant arguments" addressof:arguments
67	var Link:Argument arg :> argument local Address
68	arguments 0 := addressof:arg
69	var Relation originals := var Relation empty_relation
70	var Link:List intern_locals :> new List
71	module define "pliant locals" addressof:intern_locals
72	var Pointer:Arrow c :> external_locals first
73	while c<>null
74	check (addressof entry_type:c)=(addressof LocalVariable)
75	var Link:LocalVariable l :> c map LocalVariable
76	var Pointer:Type t :> l:body type
77	var Link:LocalVariable l2 :> new LocalVariable
78	l2 name := l name
79	l2 function :> fun
80	l2 body :> argument local t
81	l2:body name := l:body name
82	l2 access := l access
83	module define l:name addressof:l2
84	intern_locals append addressof:l2
85	originals define addressof:l2 null addressof:l
86	c :> external_locals next c
87	fun name := "frozen expression at "+e:position
88	fun position := e position
89	fun define_argument Address access_read+access_byvalue "" null
90	fun terminate_arguments 0
91	functions append addressof:fun
92	module define "pliant function" addressof:fun
93	e compile
94	if error_notified
95	module rewind mark
96	if error_top_record:id=error_id_compile and final:error_message=""
97	final error_message := error_top_record message
98	return
99	var Link:Argument da :> argument local DelayedAction
100	var Link:Argument adr :> argument local Address
101	instructions2 append addressof:(instruction (the_function 'address Universal' Universal -> Address) da adr)
102	var Link:Argument field :> argument indirect Arrow adr 0
103	instructions2 append addressof:(instruction (the_function 'arrow Universal' Universal -> Arrow) (argument mapped_constant Function fun) field)
104	field :> argument indirect Arrow adr Arrow:size
105	instructions2 append addressof:(instruction (the_function 'arrow Universal' Universal -> Arrow) newobj field)
106	var Pointer:Arrow c :> intern_locals first
107	while c<>null
108	check (addressof entry_type:c)=addressof:LocalVariable
109	var Link:LocalVariable l2 :> c map LocalVariable
110	var Link:LocalVariable l :> (originals query addressof:l2 null) map LocalVariable
111	if addressof:l<>null and (e uses l2:body)
112	var Int i := 0
113	while i<type:nb_fields and (type field i):name<>l2:name
114	i := i+1
115	var Pointer:Type t :> l2:body type
116	var CBool v := (t:flags .and. type_flag_do_not_copy)=0
117	var Pointer:Arrow c2 :> byaddress first
118	while c2<>null
119	check (addressof entry_type:c2)=addressof:Ident
120	if (cast (c2 map Ident) Str)=l2:name
121	v := false
122	c2 :> byaddress next c2
123	var Int offset
124	if i<>type:nb_fields
125	offset := (type field i) offset
126	else
127	offset := type size
128	if v
129	type define_field t l2:name null
130	else
131	type define_field Address l2:name null
132	var Link:Argument field :> argument indirect Address newadr offset
133	if v
134	instructions append addressof:(instruction (the_function 'copy Universal' Universal Universal Type) l:body field (argument mapped_constant Type t))
135	else
136	instructions append addressof:(instruction (the_function 'address Universal' Universal -> Address) l:body field)
137	l2:body locate t argument_indirect
138	if v
139	l2:body pointer :> arg ; l2:body offset := offset
140	else
141	l2:body pointer :> (argument indirect Address arg offset) ; l2:body offset := 0
142	c :> intern_locals next c
143	var Link:GeneratorContext gc :> new GeneratorContext
144	gc setup e fun
145	gc optimize
146	e set_result da access_read_write
147	module rewind mark
148	r :> expressions next r
149	type terminate_fields
150	r :> functions first
151	while r<>null
152	check (addressof entry_type:r)=addressof:Function
153	var Pointer:Function f :> r map Function
154	(f arg 0) type :> pointerto type
155	r :> functions next r
156	r :> instructions first
157	while r<>null
158	final add (r map Instruction)
159	r :> instructions next r
160	r :> instructions2 first
161	while r<>null
162	final add (r map Instruction)
163	r :> instructions2 next r
164
165
166	method e freeze
167	arg_rw Expression e
168	var List expressions byaddress functions ; var Link:Type type
169	expressions append addressof:e
170	e freeze expressions byaddress functions type
171
172
173	meta 'pliant share arguments' e
174	var Pointer:Arrow r :> e:module first "pliant shared"
175	if r=null
176	return
177	if e:size<1
178	return
179	for (var Int i) 0 e:size-1
180	if not e:i:is_pure_ident
181	return
182	for (var Int i) 0 e:size-1
183	e:i compile ?
184	var Pointer:List byaddress :> r map List
185	for (var Int i) 0 e:size-1
186	var Pointer:Arrow r :> byaddress first
187	while r<>null and (r map Ident)<>(e:i:value map Ident)
188	r :> byaddress next r
189	if r=null
190	byaddress append addressof:(e:i:value map Ident)
191	if e:size=1
192	e set_result e:0:result e:0:access
193	else
194	e set_void_result
195
196
197	export '. freeze'
198	export 'pliant share arguments'