2 Copyright (C) 2001-2010, Parrot Foundation.
7 src/utils.c - Some utility functions
11 Prototypes are in F<src/misc.h>.
13 Opcode helper functions that don't really fit elsewhere.
23 #include "parrot/parrot.h"
24 #include "parrot/extend.h"
25 #include "pmc/pmc_nci.h"
27 typedef unsigned short _rand_buf
[3];
29 /* Parrot_register_move companion functions i and data */
30 typedef struct parrot_prm_context
{
31 unsigned char *dest_regs
;
32 unsigned char *src_regs
;
33 unsigned char temp_reg
;
39 reg_move_func mov_alt
;
43 /* HEADERIZER HFILE: include/parrot/misc.h */
44 /* HEADERIZER BEGIN: static */
45 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
47 static FLOATVAL
_drand48(void);
48 static FLOATVAL
_erand48(_rand_buf buf
);
49 static long _jrand48(_rand_buf buf
);
50 static long _lrand48(void);
51 static long _mrand48(void);
52 static long _nrand48(_rand_buf buf
);
53 static void _srand48(long seed
);
54 static INTVAL
COMPARE(PARROT_INTERP
,
58 __attribute__nonnull__(1)
59 __attribute__nonnull__(2)
60 __attribute__nonnull__(3)
61 __attribute__nonnull__(4);
63 static void next_rand(_rand_buf X
);
64 static void process_cycle_without_exit(
66 ARGIN(const parrot_prm_context
*c
))
67 __attribute__nonnull__(2);
69 static void rec_climb_back_and_mark(
71 ARGIN(const parrot_prm_context
*c
))
72 __attribute__nonnull__(2);
74 #define ASSERT_ARGS__drand48 __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
75 #define ASSERT_ARGS__erand48 __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
76 #define ASSERT_ARGS__jrand48 __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
77 #define ASSERT_ARGS__lrand48 __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
78 #define ASSERT_ARGS__mrand48 __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
79 #define ASSERT_ARGS__nrand48 __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
80 #define ASSERT_ARGS__srand48 __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
81 #define ASSERT_ARGS_COMPARE __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
82 PARROT_ASSERT_ARG(interp) \
83 , PARROT_ASSERT_ARG(a) \
84 , PARROT_ASSERT_ARG(b) \
85 , PARROT_ASSERT_ARG(cmp))
86 #define ASSERT_ARGS_next_rand __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
87 #define ASSERT_ARGS_process_cycle_without_exit __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
89 #define ASSERT_ARGS_rec_climb_back_and_mark __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
91 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
92 /* HEADERIZER END: static */
94 #define move_reg(from, dest, c) (c)->mov((c)->interp, (unsigned char)(dest), \
95 (unsigned char)(from), (c)->info)
99 =item C<INTVAL intval_mod(INTVAL i2, INTVAL i3)>
101 NOTE: This "corrected mod" algorithm is based on the C code on page 70
102 of [1]. Assuming correct behavior of the built-in mod operator (%) with
103 positive arguments, this algorithm implements a mathematically
104 convenient version of mod, defined thus:
106 x mod y = x - y * floor(x / y)
108 For more information on this definition of mod, see section 3.4 of [2],
113 [1] Donald E. Knuth, *MMIXware: A RISC Computer for the Third
114 Millennium* Springer, 1999.
116 [2] Ronald L. Graham, Donald E. Knuth and Oren Patashnik, *Concrete
117 Mathematics*, Second Edition. Addison-Wesley, 1994.
123 PARROT_CONST_FUNCTION
124 PARROT_WARN_UNUSED_RESULT
126 intval_mod(INTVAL i2
, INTVAL i3
)
128 ASSERT_ARGS(intval_mod
)
140 if (y
< 0) { s
+= 2; y
= -y
; }
141 if (z
< 0) { s
+= 1; z
= -z
; }
145 if (r
) { /* # 36003 */
148 case 1: r
= r
- z
; break;
149 case 2: r
= z
- r
; break;
150 case 3: r
= -r
; break;
161 =item C<FLOATVAL floatval_mod(FLOATVAL n2, FLOATVAL n3)>
163 Returns C<n2 mod n3>.
165 Includes a workaround for buggy code generation in the C<lcc> compiler.
171 PARROT_CONST_FUNCTION
172 PARROT_WARN_UNUSED_RESULT
174 floatval_mod(FLOATVAL n2
, FLOATVAL n3
)
176 ASSERT_ARGS(floatval_mod
)
179 /* Another workaround for buggy code generation in the lcc compiler-
180 * adding a temporary variable makes it pass the test.
182 const FLOATVAL temp
= n3
* floor(n2
/ n3
);
184 return !FLOAT_IS_ZERO(n3
)
188 return !FLOAT_IS_ZERO(n3
)
189 ? (n2
- n3
* floor(n2
/ n3
))
199 =head2 Random Number Generator
201 Based on the C<rand48()> family of functions.
210 * currently undefined
212 #ifndef PARROT_HAS_DRAND48
215 * s. man drand48, SuS V2
217 * X(n+1) = ( aX(n) + c ) mod 2^48
221 # define A_mid 0xDEEC
224 # define SEED_LO 0x330E
226 static _rand_buf a
= { A_lo
, A_mid
, A_hi
};
227 static _rand_buf last_rand
;
228 static unsigned short c
= C
;
232 =item C<static void next_rand(_rand_buf X)>
234 Returns the next random number in C<X>.
241 next_rand(_rand_buf X
)
243 ASSERT_ARGS(next_rand
)
244 unsigned short lo
, mid
, hi
;
247 /* 48 bit mul, one short at a time */
250 mid
= (t
>> 16) & 0xffff;
252 t
= X
[1] * a
[0] + X
[0] * a
[1] + mid
;
254 hi
= (t
>> 16) & 0xffff;
256 t
= X
[2] * a
[0] + X
[1] * a
[1] + X
[0] * a
[2] + hi
;
265 =item C<static FLOATVAL _erand48(_rand_buf buf)>
267 Returns a C<double> in the interval C<[0.0, 1.0)>.
274 _erand48(_rand_buf buf
)
276 ASSERT_ARGS(_erand48
)
279 r
= ((buf
[0] / 65536.0 + buf
[1]) / 65536.0 + buf
[2]) / 65536.0;
285 =item C<static FLOATVAL _drand48(void)>
287 Returns a C<double> in the interval C<[0.0, 1.0)>.
296 ASSERT_ARGS(_drand48
)
297 return _erand48(last_rand
);
302 =item C<static long _jrand48(_rand_buf buf)>
304 Returns a C<long> in the interval C<[-2^31, 2^31)>.
311 _jrand48(_rand_buf buf
)
313 ASSERT_ARGS(_jrand48
)
316 ret
= buf
[2] << 16 | buf
[1];
322 =item C<static long _nrand48(_rand_buf buf)>
324 Returns a C<long> in the interval C<[0, 2^31)>.
331 _nrand48(_rand_buf buf
)
333 ASSERT_ARGS(_nrand48
)
334 return _jrand48(buf
) & 0x7fffffff;
339 =item C<static long _lrand48(void)>
341 Returns a C<long> in the interval C<[0, 2^31)>.
350 ASSERT_ARGS(_lrand48
)
351 return _nrand48(last_rand
);
356 =item C<static long _mrand48(void)>
358 Returns a C<long> in the interval C<[-2^31, 2^31)>.
367 ASSERT_ARGS(_mrand48
)
368 return _jrand48(last_rand
);
373 =item C<static void _srand48(long seed)>
375 Sets the high order 32 bits to the argument C<seed>. The low order 16
376 bits are set to the arbitrary value 0x330e.
385 ASSERT_ARGS(_srand48
)
386 last_rand
[0] = SEED_LO
;
387 last_rand
[1] = (unsigned short)(seed
& 0xffff);
388 last_rand
[2] = (unsigned short)((seed
>> 16) & 0xffff);
390 * reinit a, c if changed by lcong48()
401 # define _drand48 drand48
402 # define _erand48(b) erand48(b)
404 # define _lrand48 lrand48
405 # define _nrand48(b) nrand48(b)
407 # define _mrand48 mrand48
408 # define _jrand48(b) jrand48(b)
410 # define _srand48 srand48
416 =item C<FLOATVAL Parrot_float_rand(INTVAL how_random)>
418 Returns a C<FLOATVAL> uniformly distributed in the in the interval
421 C<how_random> is currently ignored.
428 PARROT_WARN_UNUSED_RESULT
430 Parrot_float_rand(INTVAL how_random
)
432 ASSERT_ARGS(Parrot_float_rand
)
435 return _drand48(); /* [0.0..1.0] */
440 =item C<INTVAL Parrot_uint_rand(INTVAL how_random)>
442 Returns an C<INTVAL> uniformly distributed in the interval C<[0, 2^31)>.
444 C<how_random> is ignored.
451 PARROT_WARN_UNUSED_RESULT
453 Parrot_uint_rand(INTVAL how_random
)
455 ASSERT_ARGS(Parrot_uint_rand
)
458 return _lrand48(); /* [0..2^31] */
463 =item C<INTVAL Parrot_int_rand(INTVAL how_random)>
465 Returns an C<INTVAL> in the interval C<[-2^31, 2^31)>.
467 C<how_random> is ignored.
474 PARROT_WARN_UNUSED_RESULT
476 Parrot_int_rand(INTVAL how_random
)
478 ASSERT_ARGS(Parrot_int_rand
)
481 return _mrand48(); /* [-2^31..2^31] */
486 =item C<INTVAL Parrot_range_rand(INTVAL from, INTVAL to, INTVAL how_random)>
488 Returns an C<INTVAL> in the range C<[from, to]>.
490 C<how_random> is ignored.
497 PARROT_WARN_UNUSED_RESULT
499 Parrot_range_rand(INTVAL from
, INTVAL to
, INTVAL how_random
)
501 ASSERT_ARGS(Parrot_range_rand
)
502 const double spread
= (double)(to
- from
+ 1);
503 const double randpart
= Parrot_float_rand(how_random
);
504 const INTVAL raw
= from
+ (INTVAL
)(spread
* randpart
);
511 =item C<void Parrot_srand(INTVAL seed)>
513 Seeds the random number generator with C<seed>.
521 Parrot_srand(INTVAL seed
)
523 ASSERT_ARGS(Parrot_srand
)
528 /* &gen_from_enum(tm.pasm) */
544 =item C<PMC* Parrot_tm_to_array(PARROT_INTERP, const struct tm *tm)>
546 Helper to convert a B<struct tm *> to an Array
553 PARROT_WARN_UNUSED_RESULT
554 PARROT_CANNOT_RETURN_NULL
556 Parrot_tm_to_array(PARROT_INTERP
, ARGIN(const struct tm
*tm
))
558 ASSERT_ARGS(Parrot_tm_to_array
)
560 PMC
* const Array
= Parrot_pmc_new(interp
,
561 Parrot_get_ctx_HLL_type(interp
, enum_class_FixedIntegerArray
));
562 VTABLE_set_integer_native(interp
, Array
, 9);
564 VTABLE_set_integer_keyed_int(interp
, Array
, 0, tm
->tm_sec
);
565 VTABLE_set_integer_keyed_int(interp
, Array
, 1, tm
->tm_min
);
566 VTABLE_set_integer_keyed_int(interp
, Array
, 2, tm
->tm_hour
);
567 VTABLE_set_integer_keyed_int(interp
, Array
, 3, tm
->tm_mday
);
568 VTABLE_set_integer_keyed_int(interp
, Array
, 4, tm
->tm_mon
+ 1);
569 VTABLE_set_integer_keyed_int(interp
, Array
, 5, tm
->tm_year
+ 1900);
570 VTABLE_set_integer_keyed_int(interp
, Array
, 6, tm
->tm_wday
);
571 VTABLE_set_integer_keyed_int(interp
, Array
, 7, tm
->tm_yday
);
572 VTABLE_set_integer_keyed_int(interp
, Array
, 8, tm
->tm_isdst
);
579 =item C<INTVAL Parrot_byte_index(PARROT_INTERP, const STRING *base, const STRING
580 *search, UINTVAL start_offset)>
582 Looks for the location of a substring within a longer string. Takes
583 pointers to the strings and the offset within the string at which
584 to start searching as arguments.
586 Returns an offset value if it is found, or -1 if no match.
593 PARROT_WARN_UNUSED_RESULT
595 Parrot_byte_index(SHIM_INTERP
, ARGIN(const STRING
*base
),
596 ARGIN(const STRING
*search
), UINTVAL start_offset
)
598 ASSERT_ARGS(Parrot_byte_index
)
599 const char * const str_start
= base
->strstart
;
600 const INTVAL str_len
= base
->strlen
;
601 const char * const search_str
= search
->strstart
;
602 const INTVAL search_len
= search
->strlen
;
603 const char *str_pos
= str_start
+ start_offset
;
604 INTVAL len_remain
= str_len
- start_offset
;
605 const char *search_pos
;
607 /* find the next position of the first character in the search string
608 * Parrot strings can have NULLs, so strchr() won't work here */
609 while ((search_pos
= (const char *)memchr(str_pos
, *search_str
, len_remain
))) {
610 const INTVAL offset
= search_pos
- str_start
;
612 /* now look for the entire string */
613 if (memcmp(search_pos
, search_str
, search_len
) == 0)
616 /* otherwise loop and memchr() with the rest of the string */
617 len_remain
= str_len
- offset
;
618 str_pos
= search_pos
+ 1;
620 if (len_remain
< search_len
)
629 =item C<INTVAL Parrot_byte_rindex(PARROT_INTERP, const STRING *base, const
630 STRING *search, UINTVAL start_offset)>
632 Substring search (like Parrot_byte_index), but works backwards,
633 from the rightmost end of the string.
635 Returns offset value or -1 (if no match).
642 PARROT_WARN_UNUSED_RESULT
644 Parrot_byte_rindex(SHIM_INTERP
, ARGIN(const STRING
*base
),
645 ARGIN(const STRING
*search
), UINTVAL start_offset
)
647 ASSERT_ARGS(Parrot_byte_rindex
)
648 const INTVAL searchlen
= search
->strlen
;
649 const char * const search_start
= (const char *)(search
->strstart
);
650 UINTVAL max_possible_offset
= (base
->strlen
- search
->strlen
);
651 INTVAL current_offset
;
653 if (start_offset
&& start_offset
< max_possible_offset
)
654 max_possible_offset
= start_offset
;
656 for (current_offset
= max_possible_offset
; current_offset
>= 0;
658 const char * const base_start
= (char *)(base
->strstart
) + current_offset
;
659 if (memcmp(base_start
, search_start
, searchlen
) == 0) {
660 return current_offset
;
669 =item C<static void rec_climb_back_and_mark(int node_index, const
670 parrot_prm_context *c)>
672 Recursive function, used by Parrot_register_move to
673 climb back the graph of register moves operations.
675 The node must have a predecessor: it is implicit because if a node has
676 a node_index, it must have a predecessor because the node_index are the
677 index of registers in dest_regs[] array, so by definition they have
678 a corrsponding src_regs register.
680 Then it emits the move operation with its predecessor, or its backup
681 if already used/visited.
683 Then continues the climbing if the predecessor was not modified, anf in that
684 case marks it, and set node_index as its backup.
686 node_index ... the index of a destination (i.e. with a pred.) register
687 c ... the graph and all the needed params : the context
694 rec_climb_back_and_mark(int node_index
, ARGIN(const parrot_prm_context
*c
))
696 ASSERT_ARGS(rec_climb_back_and_mark
)
697 const int node
= c
->dest_regs
[node_index
];
698 const int pred
= c
->src_regs
[node_index
];
699 const int pred_index
= c
->reg_to_index
[pred
];
701 if (pred_index
< 0) { /* pred has no predecessor */
702 move_reg(pred
, node
, c
);
704 else { /* pred has a predecessor, so may be processed */
705 const int src
= c
->backup
[pred_index
];
706 if (src
< 0) { /* not visited */
707 move_reg(pred
, node
, c
);
708 c
->backup
[pred_index
] = node
; /* marks pred*/
709 rec_climb_back_and_mark(pred_index
, c
);
711 else { /* already visited, use backup instead */
712 move_reg(src
, node
, c
);
720 =item C<static void process_cycle_without_exit(int node_index, const
721 parrot_prm_context *c)>
723 Recursive function, used by Parrot_register_move to handle the case
724 of cycles without exits, that are cycles of move ops between registers
725 where each register has exactly one predecessor and one successor
727 For instance: 1-->2, 2-->3, 3-->1
729 node_index ... the index of a destination (i.e. with a pred.) register
730 c ... the graph and all the needed params : the context
737 process_cycle_without_exit(int node_index
, ARGIN(const parrot_prm_context
*c
))
739 ASSERT_ARGS(process_cycle_without_exit
)
740 const int pred
= c
->src_regs
[node_index
];
742 /* let's try the alternate move function*/
745 ? c
->mov_alt(c
->interp
, c
->dest_regs
[node_index
], pred
, c
->info
)
748 if (0 == alt
) { /* use temp reg */
749 move_reg(c
->dest_regs
[node_index
], c
->temp_reg
, c
);
750 c
->backup
[node_index
] = c
->temp_reg
;
753 c
->backup
[node_index
] = c
->dest_regs
[node_index
];
755 rec_climb_back_and_mark(node_index
, c
);
760 =item C<void Parrot_register_move(PARROT_INTERP, int n_regs, unsigned char
761 *dest_regs, unsigned char *src_regs, unsigned char temp_reg, reg_move_func mov,
762 reg_move_func mov_alt, void *info)>
764 Move C<n_regs> from the given register list C<src_regs> to C<dest_regs>.
766 n_regs ... amount of registers to move
767 dest_regs ... list of register numbers 0..255
768 src_regs ... list of register numbers 0..255
769 temp_reg ... a register number not in one of these lists
770 mov ... a register move function to be called to move one register
771 mov_alt ... a register move function to be called to move one register
772 which triese fetching from an alternate src (or NULLfunc):
774 (void) (mov)(interp, dest, src, info);
775 moved = (mov_alt)(interp, dest, src, info);
777 Some C<dest_regs> might be the same as C<src_regs>, which makes this a bit
778 non-trivial, because if the destination is already clobbered, using it
779 later as source doesn"t work. E.g.
782 1 <- 0 # register 0 already clobbered
788 3 <- 2 # register 2 already clobbered - reorder moves
790 To handle such cases, we do:
792 a) rearrange the order of moves (not possible in the first case)
793 and/or if that failed:
794 b) if an alternate move function is available, it may fetch the
795 source from a different (non-clobbered) location - call it.
796 if the function returns 0 also use c)
797 c) if no alternate move function is available, use the temp reg
799 The amount of register moves should of course be minimal.
801 TODO The current implementation will not work for following cases
803 Talked to Leo and he said those cases are not likely (Vishal Soni).
804 1. I0->I1 I1->I0 I0->I3
807 TODO: Add tests for the above conditions.
815 Parrot_register_move(PARROT_INTERP
,
817 ARGOUT(unsigned char *dest_regs
),
818 ARGIN(unsigned char *src_regs
),
819 unsigned char temp_reg
,
821 reg_move_func mov_alt
,
824 ASSERT_ARGS(Parrot_register_move
)
829 int* reg_to_index
= NULL
;
830 parrot_prm_context c
;
836 if (src_regs
[0] != dest_regs
[0])
837 mov(interp
, dest_regs
[0], src_regs
[0], info
);
845 c
.src_regs
= src_regs
;
846 c
.dest_regs
= dest_regs
;
847 c
.temp_reg
= temp_reg
;
849 /* compute max_reg, the max reg number + 1 */
850 for (i
= 0; i
< n_regs
; ++i
) {
851 if (src_regs
[i
] > max_reg
)
852 max_reg
= src_regs
[i
];
853 if (dest_regs
[i
] > max_reg
)
854 max_reg
= dest_regs
[i
];
859 /* allocate space for data structures */
860 /* NOTA: data structures could be kept allocated somewhere waiting to get reused...*/
861 c
.nb_succ
= nb_succ
= mem_gc_allocate_n_zeroed_typed(interp
, n_regs
, int);
862 c
.backup
= backup
= mem_gc_allocate_n_zeroed_typed(interp
, n_regs
, int);
863 c
.reg_to_index
= reg_to_index
= mem_gc_allocate_n_zeroed_typed(interp
, max_reg
, int);
865 /* init backup array */
866 for (i
= 0; i
< n_regs
; ++i
)
869 /* fill in the conversion array between a register number and its index */
870 for (i
= 0; i
< max_reg
; ++i
)
871 reg_to_index
[i
] = -1;
872 for (i
= 0; i
< n_regs
; ++i
) {
873 const int index
= dest_regs
[i
];
874 if (index
!= src_regs
[i
]) /* get rid of self-assignment */
875 reg_to_index
[index
] = i
;
878 /* count the nb of successors for each reg index */
879 for (i
= 0; i
< n_regs
; ++i
) {
880 const int index
= reg_to_index
[ src_regs
[i
] ];
881 if (index
>= 0) /* not interested in the wells that have no preds */
884 /* process each well if any */
885 for (i
= 0; i
< n_regs
; ++i
) {
886 if (0 == nb_succ
[i
]) { /* a well */
887 rec_climb_back_and_mark(i
, &c
);
891 /* process remaining dest registers not processed */
892 /* remaining nodes are members of cycles without exits */
893 for (i
= 0; i
< n_regs
; ++i
) {
894 if (0 < nb_succ
[i
] && 0 > backup
[i
]) { /* not a well nor visited*/
895 process_cycle_without_exit(i
, &c
);
899 mem_gc_free(interp
, nb_succ
);
900 mem_gc_free(interp
, reg_to_index
);
901 mem_gc_free(interp
, backup
);
904 typedef INTVAL (*sort_func_t
)(PARROT_INTERP
, void *, void *);
908 =item C<static INTVAL COMPARE(PARROT_INTERP, void *a, void *b, PMC *cmp)>
910 General PMC comparison function. Takes two PMCs. Returns 0 if they are equal,
911 returns 1 if C<a> is bigger, and returns -1 if C<b> is bigger.
917 /* TODO: Macroize COMPARE */
918 /* This is an awfully expensive function to call, what with all the */
919 /* comparisons that never change. We ought to precompute everything. */
920 /* XXX We should be able to guarantee that *a and *b never change via const parameters. */
922 COMPARE(PARROT_INTERP
, ARGIN(void *a
), ARGIN(void *b
), ARGIN(PMC
*cmp
))
926 if (PMC_IS_NULL(cmp
))
927 return VTABLE_cmp(interp
, (PMC
*)a
, (PMC
*)b
);
929 if (cmp
->vtable
->base_type
== enum_class_NCI
) {
930 const sort_func_t f
= (sort_func_t
)D2FPTR(PARROT_NCI(cmp
)->func
);
931 return f(interp
, a
, b
);
934 Parrot_ext_call(interp
, cmp
, "PP->I", a
, b
, &result
);
940 =item C<void Parrot_quicksort(PARROT_INTERP, void **data, UINTVAL n, PMC *cmp)>
942 Perform a quicksort on a PMC array.
949 Parrot_quicksort(PARROT_INTERP
, ARGMOD(void **data
), UINTVAL n
, ARGIN(PMC
*cmp
))
951 ASSERT_ARGS(Parrot_quicksort
)
953 UINTVAL i
, j
, ln
, rn
;
961 for (i
= 0, j
= n
; ;) {
964 while (j
> 0 && COMPARE(interp
, data
[j
], data
[0], cmp
) > 0);
968 while (i
< j
&& COMPARE(interp
, data
[i
], data
[0], cmp
) < 0);
988 Parrot_quicksort(interp
, data
, ln
, cmp
);
993 Parrot_quicksort(interp
, data
+ j
, rn
, cmp
);
1008 * c-file-style: "parrot"
1010 * vim: expandtab shiftwidth=4: