1 /* Simulate storage of variables into target memory.
2 Copyright (C) 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Thomas and Brooks Moses
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
29 #include "constructor.h"
31 #include "trans-const.h"
32 #include "trans-types.h"
33 #include "target-memory.h"
35 /* --------------------------------------------------------------- */
36 /* Calculate the size of an expression. */
39 size_array (gfc_expr
*e
)
42 gfc_constructor
*c
= gfc_constructor_first (e
->value
.constructor
);
43 size_t elt_size
= gfc_target_expr_size (c
->expr
);
45 gfc_array_size (e
, &array_size
);
46 return (size_t)mpz_get_ui (array_size
) * elt_size
;
50 size_integer (int kind
)
52 return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind
)));;
59 return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind
)));;
64 size_complex (int kind
)
66 return 2 * size_float (kind
);
71 size_logical (int kind
)
73 return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind
)));;
78 size_character (int length
, int kind
)
80 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
81 return length
* gfc_character_kinds
[i
].bit_size
/ 8;
86 gfc_target_expr_size (gfc_expr
*e
)
90 gcc_assert (e
!= NULL
);
92 if (e
->expr_type
== EXPR_ARRAY
)
93 return size_array (e
);
98 return size_integer (e
->ts
.kind
);
100 return size_float (e
->ts
.kind
);
102 return size_complex (e
->ts
.kind
);
104 return size_logical (e
->ts
.kind
);
106 if (e
->expr_type
== EXPR_SUBSTRING
&& e
->ref
)
110 gfc_extract_int (e
->ref
->u
.ss
.start
, &start
);
111 gfc_extract_int (e
->ref
->u
.ss
.end
, &end
);
112 return size_character (MAX(end
- start
+ 1, 0), e
->ts
.kind
);
115 return size_character (e
->value
.character
.length
, e
->ts
.kind
);
117 return e
->representation
.length
;
119 type
= gfc_typenode_for_spec (&e
->ts
);
120 return int_size_in_bytes (type
);
122 gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
128 /* The encode_* functions export a value into a buffer, and
129 return the number of bytes of the buffer that have been
133 encode_array (gfc_expr
*expr
, unsigned char *buffer
, size_t buffer_size
)
139 gfc_constructor_base ctor
= expr
->value
.constructor
;
141 gfc_array_size (expr
, &array_size
);
142 for (i
= 0; i
< (int)mpz_get_ui (array_size
); i
++)
144 ptr
+= gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor
, i
),
145 &buffer
[ptr
], buffer_size
- ptr
);
148 mpz_clear (array_size
);
154 encode_integer (int kind
, mpz_t integer
, unsigned char *buffer
,
157 return native_encode_expr (gfc_conv_mpz_to_tree (integer
, kind
),
158 buffer
, buffer_size
);
163 encode_float (int kind
, mpfr_t real
, unsigned char *buffer
, size_t buffer_size
)
165 return native_encode_expr (gfc_conv_mpfr_to_tree (real
, kind
, 0), buffer
,
171 encode_complex (int kind
, mpc_t cmplx
,
172 unsigned char *buffer
, size_t buffer_size
)
175 size
= encode_float (kind
, mpc_realref (cmplx
), &buffer
[0], buffer_size
);
176 size
+= encode_float (kind
, mpc_imagref (cmplx
),
177 &buffer
[size
], buffer_size
- size
);
183 encode_logical (int kind
, int logical
, unsigned char *buffer
, size_t buffer_size
)
185 return native_encode_expr (build_int_cst (gfc_get_logical_type (kind
),
187 buffer
, buffer_size
);
192 gfc_encode_character (int kind
, int length
, const gfc_char_t
*string
,
193 unsigned char *buffer
, size_t buffer_size
)
195 size_t elsize
= size_character (1, kind
);
196 tree type
= gfc_get_char_type (kind
);
199 gcc_assert (buffer_size
>= size_character (length
, kind
));
201 for (i
= 0; i
< length
; i
++)
202 native_encode_expr (build_int_cst (type
, string
[i
]), &buffer
[i
*elsize
],
210 encode_derived (gfc_expr
*source
, unsigned char *buffer
, size_t buffer_size
)
217 type
= gfc_typenode_for_spec (&source
->ts
);
219 for (c
= gfc_constructor_first (source
->value
.constructor
),
220 cmp
= source
->ts
.u
.derived
->components
;
222 c
= gfc_constructor_next (c
), cmp
= cmp
->next
)
227 ptr
= TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp
->backend_decl
))
228 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp
->backend_decl
))/8;
230 if (c
->expr
->expr_type
== EXPR_NULL
)
231 memset (&buffer
[ptr
], 0,
232 int_size_in_bytes (TREE_TYPE (cmp
->backend_decl
)));
234 gfc_target_encode_expr (c
->expr
, &buffer
[ptr
],
238 return int_size_in_bytes (type
);
242 /* Write a constant expression in binary form to a buffer. */
244 gfc_target_encode_expr (gfc_expr
*source
, unsigned char *buffer
,
250 if (source
->expr_type
== EXPR_ARRAY
)
251 return encode_array (source
, buffer
, buffer_size
);
253 gcc_assert (source
->expr_type
== EXPR_CONSTANT
254 || source
->expr_type
== EXPR_STRUCTURE
255 || source
->expr_type
== EXPR_SUBSTRING
);
257 /* If we already have a target-memory representation, we use that rather
258 than recreating one. */
259 if (source
->representation
.string
)
261 memcpy (buffer
, source
->representation
.string
,
262 source
->representation
.length
);
263 return source
->representation
.length
;
266 switch (source
->ts
.type
)
269 return encode_integer (source
->ts
.kind
, source
->value
.integer
, buffer
,
272 return encode_float (source
->ts
.kind
, source
->value
.real
, buffer
,
275 return encode_complex (source
->ts
.kind
, source
->value
.complex,
276 buffer
, buffer_size
);
278 return encode_logical (source
->ts
.kind
, source
->value
.logical
, buffer
,
281 if (source
->expr_type
== EXPR_CONSTANT
|| source
->ref
== NULL
)
282 return gfc_encode_character (source
->ts
.kind
,
283 source
->value
.character
.length
,
284 source
->value
.character
.string
,
285 buffer
, buffer_size
);
290 gcc_assert (source
->expr_type
== EXPR_SUBSTRING
);
291 gfc_extract_int (source
->ref
->u
.ss
.start
, &start
);
292 gfc_extract_int (source
->ref
->u
.ss
.end
, &end
);
293 return gfc_encode_character (source
->ts
.kind
, MAX(end
- start
+ 1, 0),
294 &source
->value
.character
.string
[start
-1],
295 buffer
, buffer_size
);
299 return encode_derived (source
, buffer
, buffer_size
);
301 gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
308 interpret_array (unsigned char *buffer
, size_t buffer_size
, gfc_expr
*result
)
310 gfc_constructor_base base
= NULL
;
315 /* Calculate array size from its shape and rank. */
316 gcc_assert (result
->rank
> 0 && result
->shape
);
318 for (i
= 0; i
< result
->rank
; i
++)
319 array_size
*= (int)mpz_get_ui (result
->shape
[i
]);
321 /* Iterate over array elements, producing constructors. */
322 for (i
= 0; i
< array_size
; i
++)
324 gfc_expr
*e
= gfc_get_constant_expr (result
->ts
.type
, result
->ts
.kind
,
328 if (e
->ts
.type
== BT_CHARACTER
)
329 e
->value
.character
.length
= result
->value
.character
.length
;
331 gfc_constructor_append_expr (&base
, e
, &result
->where
);
333 ptr
+= gfc_target_interpret_expr (&buffer
[ptr
], buffer_size
- ptr
, e
);
336 result
->value
.constructor
= base
;
342 gfc_interpret_integer (int kind
, unsigned char *buffer
, size_t buffer_size
,
346 gfc_conv_tree_to_mpz (integer
,
347 native_interpret_expr (gfc_get_int_type (kind
),
348 buffer
, buffer_size
));
349 return size_integer (kind
);
354 gfc_interpret_float (int kind
, unsigned char *buffer
, size_t buffer_size
,
357 gfc_set_model_kind (kind
);
359 gfc_conv_tree_to_mpfr (real
,
360 native_interpret_expr (gfc_get_real_type (kind
),
361 buffer
, buffer_size
));
363 return size_float (kind
);
368 gfc_interpret_complex (int kind
, unsigned char *buffer
, size_t buffer_size
,
372 size
= gfc_interpret_float (kind
, &buffer
[0], buffer_size
,
373 mpc_realref (complex));
374 size
+= gfc_interpret_float (kind
, &buffer
[size
], buffer_size
- size
,
375 mpc_imagref (complex));
381 gfc_interpret_logical (int kind
, unsigned char *buffer
, size_t buffer_size
,
384 tree t
= native_interpret_expr (gfc_get_logical_type (kind
), buffer
,
386 *logical
= double_int_zero_p (tree_to_double_int (t
))
388 return size_logical (kind
);
393 gfc_interpret_character (unsigned char *buffer
, size_t buffer_size
,
398 if (result
->ts
.u
.cl
&& result
->ts
.u
.cl
->length
)
399 result
->value
.character
.length
=
400 (int) mpz_get_ui (result
->ts
.u
.cl
->length
->value
.integer
);
402 gcc_assert (buffer_size
>= size_character (result
->value
.character
.length
,
404 result
->value
.character
.string
=
405 gfc_get_wide_string (result
->value
.character
.length
+ 1);
407 if (result
->ts
.kind
== gfc_default_character_kind
)
408 for (i
= 0; i
< result
->value
.character
.length
; i
++)
409 result
->value
.character
.string
[i
] = (gfc_char_t
) buffer
[i
];
413 unsigned bytes
= size_character (1, result
->ts
.kind
);
415 gcc_assert (bytes
<= sizeof (unsigned long));
417 for (i
= 0; i
< result
->value
.character
.length
; i
++)
419 gfc_conv_tree_to_mpz (integer
,
420 native_interpret_expr (gfc_get_char_type (result
->ts
.kind
),
421 &buffer
[bytes
*i
], buffer_size
-bytes
*i
));
422 result
->value
.character
.string
[i
]
423 = (gfc_char_t
) mpz_get_ui (integer
);
429 result
->value
.character
.string
[result
->value
.character
.length
] = '\0';
431 return result
->value
.character
.length
;
436 gfc_interpret_derived (unsigned char *buffer
, size_t buffer_size
, gfc_expr
*result
)
442 /* The attributes of the derived type need to be bolted to the floor. */
443 result
->expr_type
= EXPR_STRUCTURE
;
445 type
= gfc_typenode_for_spec (&result
->ts
);
446 cmp
= result
->ts
.u
.derived
->components
;
448 /* Run through the derived type components. */
449 for (;cmp
; cmp
= cmp
->next
)
452 gfc_expr
*e
= gfc_get_constant_expr (cmp
->ts
.type
, cmp
->ts
.kind
,
456 /* Copy shape, if needed. */
457 if (cmp
->as
&& cmp
->as
->rank
)
461 e
->expr_type
= EXPR_ARRAY
;
462 e
->rank
= cmp
->as
->rank
;
464 e
->shape
= gfc_get_shape (e
->rank
);
465 for (n
= 0; n
< e
->rank
; n
++)
467 mpz_init_set_ui (e
->shape
[n
], 1);
468 mpz_add (e
->shape
[n
], e
->shape
[n
],
469 cmp
->as
->upper
[n
]->value
.integer
);
470 mpz_sub (e
->shape
[n
], e
->shape
[n
],
471 cmp
->as
->lower
[n
]->value
.integer
);
475 c
= gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
477 /* The constructor points to the component. */
478 c
->n
.component
= cmp
;
480 ptr
= TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp
->backend_decl
));
481 gfc_target_interpret_expr (&buffer
[ptr
], buffer_size
- ptr
, e
);
484 return int_size_in_bytes (type
);
488 /* Read a binary buffer to a constant expression. */
490 gfc_target_interpret_expr (unsigned char *buffer
, size_t buffer_size
,
493 if (result
->expr_type
== EXPR_ARRAY
)
494 return interpret_array (buffer
, buffer_size
, result
);
496 switch (result
->ts
.type
)
499 result
->representation
.length
=
500 gfc_interpret_integer (result
->ts
.kind
, buffer
, buffer_size
,
501 result
->value
.integer
);
505 result
->representation
.length
=
506 gfc_interpret_float (result
->ts
.kind
, buffer
, buffer_size
,
511 result
->representation
.length
=
512 gfc_interpret_complex (result
->ts
.kind
, buffer
, buffer_size
,
513 result
->value
.complex);
517 result
->representation
.length
=
518 gfc_interpret_logical (result
->ts
.kind
, buffer
, buffer_size
,
519 &result
->value
.logical
);
523 result
->representation
.length
=
524 gfc_interpret_character (buffer
, buffer_size
, result
);
528 result
->representation
.length
=
529 gfc_interpret_derived (buffer
, buffer_size
, result
);
533 gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
537 if (result
->ts
.type
== BT_CHARACTER
)
538 result
->representation
.string
539 = gfc_widechar_to_char (result
->value
.character
.string
,
540 result
->value
.character
.length
);
543 result
->representation
.string
=
544 (char *) gfc_getmem (result
->representation
.length
+ 1);
545 memcpy (result
->representation
.string
, buffer
,
546 result
->representation
.length
);
547 result
->representation
.string
[result
->representation
.length
] = '\0';
550 return result
->representation
.length
;
554 /* --------------------------------------------------------------- */
555 /* Two functions used by trans-common.c to write overlapping
556 equivalence initializers to a buffer. This is added to the union
557 and the original initializers freed. */
560 /* Writes the values of a constant expression to a char buffer. If another
561 unequal initializer has already been written to the buffer, this is an
565 expr_to_char (gfc_expr
*e
, unsigned char *data
, unsigned char *chk
, size_t len
)
571 unsigned char *buffer
;
576 /* Take a derived type, one component at a time, using the offsets from the backend
578 if (e
->ts
.type
== BT_DERIVED
)
580 for (c
= gfc_constructor_first (e
->value
.constructor
),
581 cmp
= e
->ts
.u
.derived
->components
;
582 c
; c
= gfc_constructor_next (c
), cmp
= cmp
->next
)
584 gcc_assert (cmp
&& cmp
->backend_decl
);
587 ptr
= TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp
->backend_decl
))
588 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp
->backend_decl
))/8;
589 expr_to_char (c
->expr
, &data
[ptr
], &chk
[ptr
], len
);
594 /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
595 to the target, in a buffer and check off the initialized part of the buffer. */
596 len
= gfc_target_expr_size (e
);
597 buffer
= (unsigned char*)alloca (len
);
598 len
= gfc_target_encode_expr (e
, buffer
, len
);
600 for (i
= 0; i
< (int)len
; i
++)
602 if (chk
[i
] && (buffer
[i
] != data
[i
]))
604 gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
611 memcpy (data
, buffer
, len
);
616 /* Writes the values from the equivalence initializers to a char* array
617 that will be written to the constructor to make the initializer for
618 the union declaration. */
621 gfc_merge_initializers (gfc_typespec ts
, gfc_expr
*e
, unsigned char *data
,
622 unsigned char *chk
, size_t length
)
627 switch (e
->expr_type
)
631 len
= expr_to_char (e
, &data
[0], &chk
[0], length
);
636 for (c
= gfc_constructor_first (e
->value
.constructor
);
637 c
; c
= gfc_constructor_next (c
))
639 size_t elt_size
= gfc_target_expr_size (c
->expr
);
642 len
= elt_size
* (size_t)mpz_get_si (c
->offset
);
644 len
= len
+ gfc_merge_initializers (ts
, c
->expr
, &data
[len
],
645 &chk
[len
], length
- len
);
657 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
658 When successful, no BOZ or nothing to do, true is returned. */
661 gfc_convert_boz (gfc_expr
*expr
, gfc_typespec
*ts
)
663 size_t buffer_size
, boz_bit_size
, ts_bit_size
;
665 unsigned char *buffer
;
670 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
671 && expr
->ts
.type
== BT_INTEGER
);
673 /* Don't convert BOZ to logical, character, derived etc. */
674 if (ts
->type
== BT_REAL
)
676 buffer_size
= size_float (ts
->kind
);
677 ts_bit_size
= buffer_size
* 8;
679 else if (ts
->type
== BT_COMPLEX
)
681 buffer_size
= size_complex (ts
->kind
);
682 ts_bit_size
= buffer_size
* 8 / 2;
687 /* Convert BOZ to the smallest possible integer kind. */
688 boz_bit_size
= mpz_sizeinbase (expr
->value
.integer
, 2);
690 if (boz_bit_size
> ts_bit_size
)
692 gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
693 &expr
->where
, (long) boz_bit_size
, (long) ts_bit_size
);
697 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
698 if ((unsigned) gfc_integer_kinds
[index
].bit_size
>= ts_bit_size
)
701 expr
->ts
.kind
= gfc_integer_kinds
[index
].kind
;
702 buffer_size
= MAX (buffer_size
, size_integer (expr
->ts
.kind
));
704 buffer
= (unsigned char*)alloca (buffer_size
);
705 encode_integer (expr
->ts
.kind
, expr
->value
.integer
, buffer
, buffer_size
);
706 mpz_clear (expr
->value
.integer
);
708 if (ts
->type
== BT_REAL
)
710 mpfr_init (expr
->value
.real
);
711 gfc_interpret_float (ts
->kind
, buffer
, buffer_size
, expr
->value
.real
);
715 mpc_init2 (expr
->value
.complex, mpfr_get_default_prec());
716 gfc_interpret_complex (ts
->kind
, buffer
, buffer_size
,
717 expr
->value
.complex);
720 expr
->ts
.type
= ts
->type
;
721 expr
->ts
.kind
= ts
->kind
;