1 /* Simulate storage of variables into target memory.
2 Copyright (C) 2007, 2008
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/>. */
30 #include "trans-const.h"
31 #include "trans-types.h"
32 #include "target-memory.h"
34 /* --------------------------------------------------------------- */
35 /* Calculate the size of an expression. */
38 size_array (gfc_expr
*e
)
41 size_t elt_size
= gfc_target_expr_size (e
->value
.constructor
->expr
);
43 gfc_array_size (e
, &array_size
);
44 return (size_t)mpz_get_ui (array_size
) * elt_size
;
48 size_integer (int kind
)
50 return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind
)));;
57 return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind
)));;
62 size_complex (int kind
)
64 return 2 * size_float (kind
);
69 size_logical (int kind
)
71 return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind
)));;
76 size_character (int length
, int kind
)
83 gfc_target_expr_size (gfc_expr
*e
)
87 gcc_assert (e
!= NULL
);
89 if (e
->expr_type
== EXPR_ARRAY
)
90 return size_array (e
);
95 return size_integer (e
->ts
.kind
);
97 return size_float (e
->ts
.kind
);
99 return size_complex (e
->ts
.kind
);
101 return size_logical (e
->ts
.kind
);
103 if (e
->expr_type
== EXPR_SUBSTRING
&& e
->ref
)
107 gfc_extract_int (e
->ref
->u
.ss
.start
, &start
);
108 gfc_extract_int (e
->ref
->u
.ss
.end
, &end
);
109 return size_character (MAX(end
- start
+ 1, 0), e
->ts
.kind
);
112 return size_character (e
->value
.character
.length
, e
->ts
.kind
);
114 return e
->representation
.length
;
116 type
= gfc_typenode_for_spec (&e
->ts
);
117 return int_size_in_bytes (type
);
119 gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
125 /* The encode_* functions export a value into a buffer, and
126 return the number of bytes of the buffer that have been
130 encode_array (gfc_expr
*expr
, unsigned char *buffer
, size_t buffer_size
)
136 gfc_array_size (expr
, &array_size
);
137 for (i
= 0; i
< (int)mpz_get_ui (array_size
); i
++)
139 ptr
+= gfc_target_encode_expr (gfc_get_array_element (expr
, i
),
140 &buffer
[ptr
], buffer_size
- ptr
);
143 mpz_clear (array_size
);
149 encode_integer (int kind
, mpz_t integer
, unsigned char *buffer
,
152 return native_encode_expr (gfc_conv_mpz_to_tree (integer
, kind
),
153 buffer
, buffer_size
);
158 encode_float (int kind
, mpfr_t real
, unsigned char *buffer
, size_t buffer_size
)
160 return native_encode_expr (gfc_conv_mpfr_to_tree (real
, kind
), buffer
,
166 encode_complex (int kind
, mpfr_t real
, mpfr_t imaginary
, unsigned char *buffer
,
170 size
= encode_float (kind
, real
, &buffer
[0], buffer_size
);
171 size
+= encode_float (kind
, imaginary
, &buffer
[size
], buffer_size
- size
);
177 encode_logical (int kind
, int logical
, unsigned char *buffer
, size_t buffer_size
)
179 return native_encode_expr (build_int_cst (gfc_get_logical_type (kind
),
181 buffer
, buffer_size
);
186 encode_character (int kind
, int length
, gfc_char_t
*string
,
187 unsigned char *buffer
, size_t buffer_size
)
191 gcc_assert (buffer_size
>= size_character (length
, kind
));
192 /* FIXME -- when we support wide character types, we'll need to go
193 via integers for them. For now, we keep the simple memcpy(). */
194 gcc_assert (kind
== gfc_default_character_kind
);
196 s
= gfc_widechar_to_char (string
, length
);
197 memcpy (buffer
, s
, length
);
205 encode_derived (gfc_expr
*source
, unsigned char *buffer
, size_t buffer_size
)
207 gfc_constructor
*ctr
;
212 type
= gfc_typenode_for_spec (&source
->ts
);
214 ctr
= source
->value
.constructor
;
215 cmp
= source
->ts
.derived
->components
;
216 for (;ctr
; ctr
= ctr
->next
, cmp
= cmp
->next
)
221 ptr
= TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp
->backend_decl
))
222 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp
->backend_decl
))/8;
223 gfc_target_encode_expr (ctr
->expr
, &buffer
[ptr
],
227 return int_size_in_bytes (type
);
231 /* Write a constant expression in binary form to a buffer. */
233 gfc_target_encode_expr (gfc_expr
*source
, unsigned char *buffer
,
239 if (source
->expr_type
== EXPR_ARRAY
)
240 return encode_array (source
, buffer
, buffer_size
);
242 gcc_assert (source
->expr_type
== EXPR_CONSTANT
243 || source
->expr_type
== EXPR_STRUCTURE
244 || source
->expr_type
== EXPR_SUBSTRING
);
246 /* If we already have a target-memory representation, we use that rather
247 than recreating one. */
248 if (source
->representation
.string
)
250 memcpy (buffer
, source
->representation
.string
,
251 source
->representation
.length
);
252 return source
->representation
.length
;
255 switch (source
->ts
.type
)
258 return encode_integer (source
->ts
.kind
, source
->value
.integer
, buffer
,
261 return encode_float (source
->ts
.kind
, source
->value
.real
, buffer
,
264 return encode_complex (source
->ts
.kind
, source
->value
.complex.r
,
265 source
->value
.complex.i
, buffer
, buffer_size
);
267 return encode_logical (source
->ts
.kind
, source
->value
.logical
, buffer
,
270 if (source
->expr_type
== EXPR_CONSTANT
|| source
->ref
== NULL
)
271 return encode_character (source
->ts
.kind
,
272 source
->value
.character
.length
,
273 source
->value
.character
.string
, buffer
,
279 gcc_assert (source
->expr_type
== EXPR_SUBSTRING
);
280 gfc_extract_int (source
->ref
->u
.ss
.start
, &start
);
281 gfc_extract_int (source
->ref
->u
.ss
.end
, &end
);
282 return encode_character (source
->ts
.kind
,
283 MAX(end
- start
+ 1, 0),
284 &source
->value
.character
.string
[start
-1],
285 buffer
, buffer_size
);
289 return encode_derived (source
, buffer
, buffer_size
);
291 gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
298 interpret_array (unsigned char *buffer
, size_t buffer_size
, gfc_expr
*result
)
303 gfc_constructor
*head
= NULL
, *tail
= NULL
;
305 /* Calculate array size from its shape and rank. */
306 gcc_assert (result
->rank
> 0 && result
->shape
);
308 for (i
= 0; i
< result
->rank
; i
++)
309 array_size
*= (int)mpz_get_ui (result
->shape
[i
]);
311 /* Iterate over array elements, producing constructors. */
312 for (i
= 0; i
< array_size
; i
++)
315 head
= tail
= gfc_get_constructor ();
318 tail
->next
= gfc_get_constructor ();
322 tail
->where
= result
->where
;
323 tail
->expr
= gfc_constant_result (result
->ts
.type
,
324 result
->ts
.kind
, &result
->where
);
325 tail
->expr
->ts
= result
->ts
;
327 if (tail
->expr
->ts
.type
== BT_CHARACTER
)
328 tail
->expr
->value
.character
.length
= result
->value
.character
.length
;
330 ptr
+= gfc_target_interpret_expr (&buffer
[ptr
], buffer_size
- ptr
,
333 result
->value
.constructor
= head
;
340 gfc_interpret_integer (int kind
, unsigned char *buffer
, size_t buffer_size
,
344 gfc_conv_tree_to_mpz (integer
,
345 native_interpret_expr (gfc_get_int_type (kind
),
346 buffer
, buffer_size
));
347 return size_integer (kind
);
352 gfc_interpret_float (int kind
, unsigned char *buffer
, size_t buffer_size
,
356 gfc_conv_tree_to_mpfr (real
,
357 native_interpret_expr (gfc_get_real_type (kind
),
358 buffer
, buffer_size
));
360 return size_float (kind
);
365 gfc_interpret_complex (int kind
, unsigned char *buffer
, size_t buffer_size
,
366 mpfr_t real
, mpfr_t imaginary
)
369 size
= gfc_interpret_float (kind
, &buffer
[0], buffer_size
, real
);
370 size
+= gfc_interpret_float (kind
, &buffer
[size
], buffer_size
- size
,
377 gfc_interpret_logical (int kind
, unsigned char *buffer
, size_t buffer_size
,
380 tree t
= native_interpret_expr (gfc_get_logical_type (kind
), buffer
,
382 *logical
= double_int_zero_p (tree_to_double_int (t
))
384 return size_logical (kind
);
389 gfc_interpret_character (unsigned char *buffer
, size_t buffer_size
,
394 if (result
->ts
.cl
&& result
->ts
.cl
->length
)
395 result
->value
.character
.length
=
396 (int) mpz_get_ui (result
->ts
.cl
->length
->value
.integer
);
398 gcc_assert (buffer_size
>= size_character (result
->value
.character
.length
,
400 result
->value
.character
.string
=
401 gfc_get_wide_string (result
->value
.character
.length
+ 1);
403 gcc_assert (result
->ts
.kind
== gfc_default_character_kind
);
404 for (i
= 0; i
< result
->value
.character
.length
; i
++)
405 result
->value
.character
.string
[i
] = (gfc_char_t
) buffer
[i
];
406 result
->value
.character
.string
[result
->value
.character
.length
] = '\0';
408 return result
->value
.character
.length
;
413 gfc_interpret_derived (unsigned char *buffer
, size_t buffer_size
, gfc_expr
*result
)
416 gfc_constructor
*head
= NULL
, *tail
= NULL
;
420 /* The attributes of the derived type need to be bolted to the floor. */
421 result
->expr_type
= EXPR_STRUCTURE
;
423 type
= gfc_typenode_for_spec (&result
->ts
);
424 cmp
= result
->ts
.derived
->components
;
426 /* Run through the derived type components. */
427 for (;cmp
; cmp
= cmp
->next
)
430 head
= tail
= gfc_get_constructor ();
433 tail
->next
= gfc_get_constructor ();
437 /* The constructor points to the component. */
438 tail
->n
.component
= cmp
;
440 tail
->expr
= gfc_constant_result (cmp
->ts
.type
, cmp
->ts
.kind
,
442 tail
->expr
->ts
= cmp
->ts
;
444 /* Copy shape, if needed. */
445 if (cmp
->as
&& cmp
->as
->rank
)
449 tail
->expr
->expr_type
= EXPR_ARRAY
;
450 tail
->expr
->rank
= cmp
->as
->rank
;
452 tail
->expr
->shape
= gfc_get_shape (tail
->expr
->rank
);
453 for (n
= 0; n
< tail
->expr
->rank
; n
++)
455 mpz_init_set_ui (tail
->expr
->shape
[n
], 1);
456 mpz_add (tail
->expr
->shape
[n
], tail
->expr
->shape
[n
],
457 cmp
->as
->upper
[n
]->value
.integer
);
458 mpz_sub (tail
->expr
->shape
[n
], tail
->expr
->shape
[n
],
459 cmp
->as
->lower
[n
]->value
.integer
);
463 ptr
= TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp
->backend_decl
));
464 gfc_target_interpret_expr (&buffer
[ptr
], buffer_size
- ptr
,
467 result
->value
.constructor
= head
;
470 return int_size_in_bytes (type
);
474 /* Read a binary buffer to a constant expression. */
476 gfc_target_interpret_expr (unsigned char *buffer
, size_t buffer_size
,
479 if (result
->expr_type
== EXPR_ARRAY
)
480 return interpret_array (buffer
, buffer_size
, result
);
482 switch (result
->ts
.type
)
485 result
->representation
.length
=
486 gfc_interpret_integer (result
->ts
.kind
, buffer
, buffer_size
,
487 result
->value
.integer
);
491 result
->representation
.length
=
492 gfc_interpret_float (result
->ts
.kind
, buffer
, buffer_size
,
497 result
->representation
.length
=
498 gfc_interpret_complex (result
->ts
.kind
, buffer
, buffer_size
,
499 result
->value
.complex.r
,
500 result
->value
.complex.i
);
504 result
->representation
.length
=
505 gfc_interpret_logical (result
->ts
.kind
, buffer
, buffer_size
,
506 &result
->value
.logical
);
510 result
->representation
.length
=
511 gfc_interpret_character (buffer
, buffer_size
, result
);
515 result
->representation
.length
=
516 gfc_interpret_derived (buffer
, buffer_size
, result
);
520 gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
524 if (result
->ts
.type
== BT_CHARACTER
)
525 result
->representation
.string
526 = gfc_widechar_to_char (result
->value
.character
.string
,
527 result
->value
.character
.length
);
530 result
->representation
.string
=
531 gfc_getmem (result
->representation
.length
+ 1);
532 memcpy (result
->representation
.string
, buffer
,
533 result
->representation
.length
);
534 result
->representation
.string
[result
->representation
.length
] = '\0';
537 return result
->representation
.length
;
541 /* --------------------------------------------------------------- */
542 /* Two functions used by trans-common.c to write overlapping
543 equivalence initializers to a buffer. This is added to the union
544 and the original initializers freed. */
547 /* Writes the values of a constant expression to a char buffer. If another
548 unequal initializer has already been written to the buffer, this is an
552 expr_to_char (gfc_expr
*e
, unsigned char *data
, unsigned char *chk
, size_t len
)
556 gfc_constructor
*ctr
;
558 unsigned char *buffer
;
563 /* Take a derived type, one component at a time, using the offsets from the backend
565 if (e
->ts
.type
== BT_DERIVED
)
567 ctr
= e
->value
.constructor
;
568 cmp
= e
->ts
.derived
->components
;
569 for (;ctr
; ctr
= ctr
->next
, cmp
= cmp
->next
)
571 gcc_assert (cmp
&& cmp
->backend_decl
);
574 ptr
= TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp
->backend_decl
))
575 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp
->backend_decl
))/8;
576 expr_to_char (ctr
->expr
, &data
[ptr
], &chk
[ptr
], len
);
581 /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
582 to the target, in a buffer and check off the initialized part of the buffer. */
583 len
= gfc_target_expr_size (e
);
584 buffer
= (unsigned char*)alloca (len
);
585 len
= gfc_target_encode_expr (e
, buffer
, len
);
587 for (i
= 0; i
< (int)len
; i
++)
589 if (chk
[i
] && (buffer
[i
] != data
[i
]))
591 gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
598 memcpy (data
, buffer
, len
);
603 /* Writes the values from the equivalence initializers to a char* array
604 that will be written to the constructor to make the initializer for
605 the union declaration. */
608 gfc_merge_initializers (gfc_typespec ts
, gfc_expr
*e
, unsigned char *data
,
609 unsigned char *chk
, size_t length
)
614 switch (e
->expr_type
)
618 len
= expr_to_char (e
, &data
[0], &chk
[0], length
);
623 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
625 size_t elt_size
= gfc_target_expr_size (c
->expr
);
628 len
= elt_size
* (size_t)mpz_get_si (c
->n
.offset
);
630 len
= len
+ gfc_merge_initializers (ts
, c
->expr
, &data
[len
],
631 &chk
[len
], length
- len
);
643 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
644 When successful, no BOZ or nothing to do, true is returned. */
647 gfc_convert_boz (gfc_expr
*expr
, gfc_typespec
*ts
)
649 size_t buffer_size
, boz_bit_size
, ts_bit_size
;
651 unsigned char *buffer
;
656 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
657 && expr
->ts
.type
== BT_INTEGER
);
659 /* Don't convert BOZ to logical, character, derived etc. */
660 if (ts
->type
== BT_REAL
)
662 buffer_size
= size_float (ts
->kind
);
663 ts_bit_size
= buffer_size
* 8;
665 else if (ts
->type
== BT_COMPLEX
)
667 buffer_size
= size_complex (ts
->kind
);
668 ts_bit_size
= buffer_size
* 8 / 2;
673 /* Convert BOZ to the smallest possible integer kind. */
674 boz_bit_size
= mpz_sizeinbase (expr
->value
.integer
, 2);
676 if (boz_bit_size
> ts_bit_size
)
678 gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
679 &expr
->where
, (long) boz_bit_size
, (long) ts_bit_size
);
683 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
685 if ((unsigned) gfc_integer_kinds
[index
].bit_size
>= ts_bit_size
)
689 expr
->ts
.kind
= gfc_integer_kinds
[index
].kind
;
690 buffer_size
= MAX (buffer_size
, size_integer (expr
->ts
.kind
));
692 buffer
= (unsigned char*)alloca (buffer_size
);
693 encode_integer (expr
->ts
.kind
, expr
->value
.integer
, buffer
, buffer_size
);
694 mpz_clear (expr
->value
.integer
);
696 if (ts
->type
== BT_REAL
)
698 mpfr_init (expr
->value
.real
);
699 gfc_interpret_float (ts
->kind
, buffer
, buffer_size
, expr
->value
.real
);
703 mpfr_init (expr
->value
.complex.r
);
704 mpfr_init (expr
->value
.complex.i
);
705 gfc_interpret_complex (ts
->kind
, buffer
, buffer_size
,
706 expr
->value
.complex.r
, expr
->value
.complex.i
);
709 expr
->ts
.type
= ts
->type
;
710 expr
->ts
.kind
= ts
->kind
;