-
Notifications
You must be signed in to change notification settings - Fork 528
/
inline.h
3814 lines (2981 loc) · 114 KB
/
inline.h
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/* inline.h
*
* Copyright (C) 2012 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
* This file contains tables and code adapted from
* https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this
* copyright notice:
Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is furnished to do
so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
*
* This file is a home for static inline functions that cannot go in other
* header files, because they depend on proto.h (included after most other
* headers) or struct definitions.
*
* Note also perlstatic.h for functions that can't or shouldn't be inlined, but
* whose details should be exposed to the compiler, for such things as tail
* call optimization.
*
* Each section names the header file that the functions "belong" to.
*/
/* ------------------------------- av.h ------------------------------- */
/*
=for apidoc_section $AV
=for apidoc av_count
Returns the number of elements in the array C<av>. This is the true length of
the array, including any undefined elements. It is always the same as
S<C<av_top_index(av) + 1>>.
=cut
*/
PERL_STATIC_INLINE Size_t
Perl_av_count(pTHX_ AV *av)
{
PERL_ARGS_ASSERT_AV_COUNT;
assert(SvTYPE(av) == SVt_PVAV);
return AvFILL(av) + 1;
}
/* ------------------------------- av.c ------------------------------- */
/*
=for apidoc av_store_simple
This is a cut-down version of av_store that assumes that the array is
very straightforward - no magic, not readonly, and AvREAL - and that
C<key> is not negative. This function MUST NOT be used in situations
where any of those assumptions may not hold.
Stores an SV in an array. The array index is specified as C<key>. It
can be dereferenced to get the C<SV*> that was stored there (= C<val>)).
Note that the caller is responsible for suitably incrementing the reference
count of C<val> before the call.
Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>.
=cut
*/
PERL_STATIC_INLINE SV**
Perl_av_store_simple(pTHX_ AV *av, SSize_t key, SV *val)
{
SV** ary;
PERL_ARGS_ASSERT_AV_STORE_SIMPLE;
assert(SvTYPE(av) == SVt_PVAV);
assert(!SvMAGICAL(av));
assert(!SvREADONLY(av));
assert(AvREAL(av));
assert(key > -1);
ary = AvARRAY(av);
if (AvFILLp(av) < key) {
if (key > AvMAX(av)) {
av_extend(av,key);
ary = AvARRAY(av);
}
AvFILLp(av) = key;
} else
SvREFCNT_dec(ary[key]);
ary[key] = val;
return &ary[key];
}
/*
=for apidoc av_fetch_simple
This is a cut-down version of av_fetch that assumes that the array is
very straightforward - no magic, not readonly, and AvREAL - and that
C<key> is not negative. This function MUST NOT be used in situations
where any of those assumptions may not hold.
Returns the SV at the specified index in the array. The C<key> is the
index. If lval is true, you are guaranteed to get a real SV back (in case
it wasn't real before), which you can then modify. Check that the return
value is non-null before dereferencing it to a C<SV*>.
The rough perl equivalent is C<$myarray[$key]>.
=cut
*/
PERL_STATIC_INLINE SV**
Perl_av_fetch_simple(pTHX_ AV *av, SSize_t key, I32 lval)
{
PERL_ARGS_ASSERT_AV_FETCH_SIMPLE;
assert(SvTYPE(av) == SVt_PVAV);
assert(!SvMAGICAL(av));
assert(!SvREADONLY(av));
assert(AvREAL(av));
assert(key > -1);
if ( (key > AvFILLp(av)) || !AvARRAY(av)[key]) {
return lval ? av_store_simple(av,key,newSV_type(SVt_NULL)) : NULL;
} else {
return &AvARRAY(av)[key];
}
}
/*
=for apidoc av_push_simple
This is a cut-down version of av_push that assumes that the array is very
straightforward - no magic, not readonly, and AvREAL - and that C<key> is
not less than -1. This function MUST NOT be used in situations where any
of those assumptions may not hold.
Pushes an SV (transferring control of one reference count) onto the end of the
array. The array will grow automatically to accommodate the addition.
Perl equivalent: C<push @myarray, $val;>.
=cut
*/
PERL_STATIC_INLINE void
Perl_av_push_simple(pTHX_ AV *av, SV *val)
{
PERL_ARGS_ASSERT_AV_PUSH_SIMPLE;
assert(SvTYPE(av) == SVt_PVAV);
assert(!SvMAGICAL(av));
assert(!SvREADONLY(av));
assert(AvREAL(av));
assert(AvFILLp(av) > -2);
(void)av_store_simple(av,AvFILLp(av)+1,val);
}
/*
=for apidoc av_new_alloc
This implements L<perlapi/C<newAV_alloc_x>>
and L<perlapi/C<newAV_alloc_xz>>, which are the public API for this
functionality.
Creates a new AV and allocates its SV* array.
This is similar to, but more efficient than doing:
AV *av = newAV();
av_extend(av, key);
The size parameter is used to pre-allocate a SV* array large enough to
hold at least elements C<0..(size-1)>. C<size> must be at least 1.
The C<zeroflag> parameter controls whether or not the array is NULL
initialized.
=cut
*/
PERL_STATIC_INLINE AV *
Perl_av_new_alloc(pTHX_ SSize_t size, bool zeroflag)
{
AV * const av = newAV();
SV** ary;
PERL_ARGS_ASSERT_AV_NEW_ALLOC;
assert(size > 0);
Newx(ary, size, SV*); /* Newx performs the memwrap check */
AvALLOC(av) = ary;
AvARRAY(av) = ary;
AvMAX(av) = size - 1;
if (zeroflag)
Zero(ary, size, SV*);
return av;
}
/* ------------------------------- cv.h ------------------------------- */
/*
=for apidoc_section $CV
=for apidoc CvGV
Returns the GV associated with the CV C<sv>, reifying it if necessary.
=cut
*/
PERL_STATIC_INLINE GV *
Perl_CvGV(pTHX_ CV *sv)
{
PERL_ARGS_ASSERT_CVGV;
return CvNAMED(sv)
? Perl_cvgv_from_hek(aTHX_ sv)
: ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
}
/*
=for apidoc CvDEPTH
Returns the recursion level of the CV C<sv>. Hence >= 2 indicates we are in a
recursive call.
=cut
*/
PERL_STATIC_INLINE I32 *
Perl_CvDEPTH(const CV * const sv)
{
PERL_ARGS_ASSERT_CVDEPTH;
assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
return &((XPVCV*)SvANY(sv))->xcv_depth;
}
/*
CvPROTO returns the prototype as stored, which is not necessarily what
the interpreter should be using. Specifically, the interpreter assumes
that spaces have been stripped, which has been the case if the prototype
was added by toke.c, but is generally not the case if it was added elsewhere.
Since we can't enforce the spacelessness at assignment time, this routine
provides a temporary copy at parse time with spaces removed.
I<orig> is the start of the original buffer, I<len> is the length of the
prototype and will be updated when this returns.
*/
#ifdef PERL_CORE
PERL_STATIC_INLINE char *
S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
{
SV * tmpsv;
char * tmps;
tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
tmps = SvPVX(tmpsv);
while ((*len)--) {
if (!isSPACE(*orig))
*tmps++ = *orig;
orig++;
}
*tmps = '\0';
*len = tmps - SvPVX(tmpsv);
return SvPVX(tmpsv);
}
#endif
/* ------------------------------- iperlsys.h ------------------------------- */
#if ! defined(PERL_IMPLICIT_SYS) && defined(USE_ITHREADS)
/* Otherwise this function is implemented as macros in iperlsys.h */
PERL_STATIC_INLINE bool
S_PerlEnv_putenv(pTHX_ char * str)
{
PERL_ARGS_ASSERT_PERLENV_PUTENV;
ENV_LOCK;
bool retval = putenv(str);
ENV_UNLOCK;
return retval;
}
#endif
/* ------------------------------- handy.h ------------------------------- */
#ifdef EMULATE_THREAD_SAFE_LOCALES
PERL_STATIC_INLINE int
Perl_posix_LC_foo_(pTHX_ const int c, const U8 classnum) {
int result;
LC_CTYPE_LOCK;
/* All calls to this (so far) are with a 'classnum' known at compile time,
* so the compiler should constant fold this down to a single assignment */
switch (classnum) {
case CC_ALPHANUMERIC_:result = (bool) is_posix_ALPHANUMERIC(c); break;
case CC_ALPHA_: result = (bool) is_posix_ALPHA(c); break;
case CC_ASCII_: result = (bool) is_posix_ASCII(c); break;
case CC_BLANK_: result = (bool) is_posix_BLANK(c); break;
case CC_CASED_: result = (bool) is_posix_CASED(c); break;
case CC_CNTRL_: result = (bool) is_posix_CNTRL(c); break;
case CC_DIGIT_: result = (bool) is_posix_DIGIT(c); break;
case CC_GRAPH_: result = (bool) is_posix_GRAPH(c); break;
case CC_LOWER_: result = (bool) is_posix_LOWER(c); break;
case CC_PRINT_: result = (bool) is_posix_PRINT(c); break;
case CC_PUNCT_: result = (bool) is_posix_PUNCT(c); break;
case CC_SPACE_: result = (bool) is_posix_SPACE(c); break;
case CC_UPPER_: result = (bool) is_posix_UPPER(c); break;
case CC_WORDCHAR_: result = (bool) is_posix_WORDCHAR(c); break;
case CC_XDIGIT_: result = (bool) is_posix_XDIGIT(c); break;
case CC_IDFIRST_: result = (bool) is_posix_IDFIRST(c); break;
case CC_TOLOWER_: result = to_posix_LOWER(c); break;
case CC_TOUPPER_: result = to_posix_UPPER(c); break;
default:
LC_CTYPE_UNLOCK;
locale_panic_(Perl_form(aTHX_ "Unknown charclass %d", classnum));
}
LC_CTYPE_UNLOCK;
return result;
}
#endif
/* ------------------------------- mg.h ------------------------------- */
#if defined(PERL_CORE) || defined(PERL_EXT)
/* assumes get-magic and stringification have already occurred */
PERL_STATIC_INLINE STRLEN
S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
{
assert(mg->mg_type == PERL_MAGIC_regex_global);
assert(mg->mg_len != -1);
if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
return (STRLEN)mg->mg_len;
else {
const STRLEN pos = (STRLEN)mg->mg_len;
/* Without this check, we may read past the end of the buffer: */
if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
return sv_or_pv_pos_u2b(sv, s, pos, NULL);
}
}
#endif
/* ------------------------------- pad.h ------------------------------ */
#if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
PERL_STATIC_INLINE bool
S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
{
PERL_ARGS_ASSERT_PADNAMEIN_SCOPE;
/* is seq within the range _LOW to _HIGH ?
* This is complicated by the fact that PL_cop_seqmax
* may have wrapped around at some point */
if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
return FALSE; /* not yet introduced */
if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
/* in compiling scope */
if (
(seq > COP_SEQ_RANGE_LOW(pn))
? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
: (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
)
return TRUE;
}
else if (
(COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
?
( seq > COP_SEQ_RANGE_LOW(pn)
|| seq <= COP_SEQ_RANGE_HIGH(pn))
: ( seq > COP_SEQ_RANGE_LOW(pn)
&& seq <= COP_SEQ_RANGE_HIGH(pn))
)
return TRUE;
return FALSE;
}
#endif
/* ------------------------------- pp.h ------------------------------- */
PERL_STATIC_INLINE I32
Perl_TOPMARK(pTHX)
{
#if 0
DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
"MARK top %p %" IVdf "\n",
PL_markstack_ptr,
(IV)*PL_markstack_ptr)));
#endif
return *PL_markstack_ptr;
}
PERL_STATIC_INLINE I32
Perl_POPMARK(pTHX)
{
#if 0
DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
"MARK pop %p %" IVdf "\n",
(PL_markstack_ptr-1),
(IV)*(PL_markstack_ptr-1))));
#endif
assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
return *PL_markstack_ptr--;
}
/* ----------------------------- regexp.h ----------------------------- */
/* PVLVs need to act as a superset of all scalar types - they are basically
* PVMGs with a few extra fields.
* REGEXPs are first class scalars, but have many fields that can't be copied
* into a PVLV body.
*
* Hence we take a different approach - instead of a copy, PVLVs store a pointer
* back to the original body. To avoid increasing the size of PVLVs just for the
* rare case of REGEXP assignment, this pointer is stored in the memory usually
* used for SvLEN(). Hence the check for SVt_PVLV below, and the ? : ternary to
* read the pointer from the two possible locations. The macro SvLEN() wraps the
* access to the union's member xpvlenu_len, but there is no equivalent macro
* for wrapping the union's member xpvlenu_rx, hence the direct reference here.
*
* See commit df6b4bd56551f2d3 for more details. */
PERL_STATIC_INLINE struct regexp *
Perl_ReANY(const REGEXP * const re)
{
XPV* const p = (XPV*)SvANY(re);
PERL_ARGS_ASSERT_REANY;
assert(isREGEXP(re));
return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
: (struct regexp *)p;
}
/* ------------------------------- utf8.h ------------------------------- */
/*
=for apidoc_section $unicode
*/
PERL_STATIC_INLINE void
Perl_append_utf8_from_native_byte(const U8 byte, U8** dest)
{
/* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
* encoded string at '*dest', updating '*dest' to include it */
PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
if (NATIVE_BYTE_IS_INVARIANT(byte))
*((*dest)++) = byte;
else {
*((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
*((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
}
}
/*
=for apidoc valid_utf8_to_uvchr
Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
known that the next character in the input UTF-8 string C<s> is well-formed
(I<e.g.>, it passes C<L<perlapi/isUTF8_CHAR>>. Surrogates, non-character code
points, and non-Unicode code points are allowed.
=cut
*/
PERL_STATIC_INLINE UV
Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
{
const UV expectlen = UTF8SKIP(s);
const U8* send = s + expectlen;
UV uv = *s;
PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
if (retlen) {
*retlen = expectlen;
}
/* An invariant is trivially returned */
if (expectlen == 1) {
return uv;
}
/* Remove the leading bits that indicate the number of bytes, leaving just
* the bits that are part of the value */
uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
/* Now, loop through the remaining bytes, accumulating each into the
* working total as we go. (I khw tried unrolling the loop for up to 4
* bytes, but there was no performance improvement) */
for (++s; s < send; s++) {
uv = UTF8_ACCUMULATE(uv, *s);
}
return UNI_TO_NATIVE(uv);
}
/*
=for apidoc is_utf8_invariant_string
Returns TRUE if the first C<len> bytes of the string C<s> are the same
regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
characters are invariant, but so also are the C1 controls.
If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
use this option, that C<s> can't have embedded C<NUL> characters and has to
have a terminating C<NUL> byte).
See also
C<L</is_utf8_string>>,
C<L</is_utf8_string_flags>>,
C<L</is_utf8_string_loc>>,
C<L</is_utf8_string_loc_flags>>,
C<L</is_utf8_string_loclen>>,
C<L</is_utf8_string_loclen_flags>>,
C<L</is_utf8_fixed_width_buf_flags>>,
C<L</is_utf8_fixed_width_buf_loc_flags>>,
C<L</is_utf8_fixed_width_buf_loclen_flags>>,
C<L</is_strict_utf8_string>>,
C<L</is_strict_utf8_string_loc>>,
C<L</is_strict_utf8_string_loclen>>,
C<L</is_c9strict_utf8_string>>,
C<L</is_c9strict_utf8_string_loc>>,
and
C<L</is_c9strict_utf8_string_loclen>>.
=cut
*/
#define is_utf8_invariant_string(s, len) \
is_utf8_invariant_string_loc(s, len, NULL)
/*
=for apidoc is_utf8_invariant_string_loc
Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
the first UTF-8 variant character in the C<ep> pointer; if all characters are
UTF-8 invariant, this function does not change the contents of C<*ep>.
=cut
*/
PERL_STATIC_INLINE bool
Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
{
const U8* send;
const U8* x = s;
PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
if (len == 0) {
len = strlen((const char *)s);
}
send = s + len;
/* This looks like 0x010101... */
# define PERL_COUNT_MULTIPLIER (~ (UINTMAX_C(0)) / 0xFF)
/* This looks like 0x808080... */
# define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
# define PERL_WORDSIZE sizeof(PERL_UINTMAX_T)
# define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
/* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
* or'ing together the lowest bits of 'x'. Hopefully the final term gets
* optimized out completely on a 32-bit system, and its mask gets optimized out
* on a 64-bit system */
# define PERL_IS_SUBWORD_ADDR(x) (1 & ( PTR2nat(x) \
| ( PTR2nat(x) >> 1) \
| ( ( (PTR2nat(x) \
& PERL_WORD_BOUNDARY_MASK) >> 2))))
#ifndef EBCDIC
/* Do the word-at-a-time iff there is at least one usable full word. That
* means that after advancing to a word boundary, there still is at least a
* full word left. The number of bytes needed to advance is 'wordsize -
* offset' unless offset is 0. */
if ((STRLEN) (send - x) >= PERL_WORDSIZE
/* This term is wordsize if subword; 0 if not */
+ PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
/* 'offset' */
- (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
{
/* Process per-byte until reach word boundary. XXX This loop could be
* eliminated if we knew that this platform had fast unaligned reads */
while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
if (! UTF8_IS_INVARIANT(*x)) {
if (ep) {
*ep = x;
}
return FALSE;
}
x++;
}
/* Here, we know we have at least one full word to process. Process
* per-word as long as we have at least a full word left */
do {
if ((* (const PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
/* Found a variant. Just return if caller doesn't want its
* exact position */
if (! ep) {
return FALSE;
}
# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
|| BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
*ep = x + variant_byte_number(* (const PERL_UINTMAX_T *) x);
assert(*ep >= s && *ep < send);
return FALSE;
# else /* If weird byte order, drop into next loop to do byte-at-a-time
checks. */
break;
# endif
}
x += PERL_WORDSIZE;
} while (x + PERL_WORDSIZE <= send);
}
#endif /* End of ! EBCDIC */
/* Process per-byte */
while (x < send) {
if (! UTF8_IS_INVARIANT(*x)) {
if (ep) {
*ep = x;
}
return FALSE;
}
x++;
}
return TRUE;
}
/* See if the platform has builtins for finding the most/least significant bit,
* and which one is right for using on 32 and 64 bit operands */
#if (__has_builtin(__builtin_clz) || PERL_GCC_VERSION_GE(3,4,0))
# if U32SIZE == INTSIZE
# define PERL_CLZ_32 __builtin_clz
# endif
# if defined(U64TYPE) && U64SIZE == INTSIZE
# define PERL_CLZ_64 __builtin_clz
# endif
#endif
#if (__has_builtin(__builtin_ctz) || PERL_GCC_VERSION_GE(3,4,0))
# if U32SIZE == INTSIZE
# define PERL_CTZ_32 __builtin_ctz
# endif
# if defined(U64TYPE) && U64SIZE == INTSIZE
# define PERL_CTZ_64 __builtin_ctz
# endif
#endif
#if (__has_builtin(__builtin_clzl) || PERL_GCC_VERSION_GE(3,4,0))
# if U32SIZE == LONGSIZE && ! defined(PERL_CLZ_32)
# define PERL_CLZ_32 __builtin_clzl
# endif
# if defined(U64TYPE) && U64SIZE == LONGSIZE && ! defined(PERL_CLZ_64)
# define PERL_CLZ_64 __builtin_clzl
# endif
#endif
#if (__has_builtin(__builtin_ctzl) || PERL_GCC_VERSION_GE(3,4,0))
# if U32SIZE == LONGSIZE && ! defined(PERL_CTZ_32)
# define PERL_CTZ_32 __builtin_ctzl
# endif
# if defined(U64TYPE) && U64SIZE == LONGSIZE && ! defined(PERL_CTZ_64)
# define PERL_CTZ_64 __builtin_ctzl
# endif
#endif
#if (__has_builtin(__builtin_clzll) || PERL_GCC_VERSION_GE(3,4,0))
# if U32SIZE == LONGLONGSIZE && ! defined(PERL_CLZ_32)
# define PERL_CLZ_32 __builtin_clzll
# endif
# if defined(U64TYPE) && U64SIZE == LONGLONGSIZE && ! defined(PERL_CLZ_64)
# define PERL_CLZ_64 __builtin_clzll
# endif
#endif
#if (__has_builtin(__builtin_ctzll) || PERL_GCC_VERSION_GE(3,4,0))
# if U32SIZE == LONGLONGSIZE && ! defined(PERL_CTZ_32)
# define PERL_CTZ_32 __builtin_ctzll
# endif
# if defined(U64TYPE) && U64SIZE == LONGLONGSIZE && ! defined(PERL_CTZ_64)
# define PERL_CTZ_64 __builtin_ctzll
# endif
#endif
#if defined(_MSC_VER)
# include <intrin.h>
# pragma intrinsic(_BitScanForward)
# pragma intrinsic(_BitScanReverse)
# ifdef _WIN64
# pragma intrinsic(_BitScanForward64)
# pragma intrinsic(_BitScanReverse64)
# endif
#endif
/* The reason there are not checks to see if ffs() and ffsl() are available for
* determining the lsb, is because these don't improve on the deBruijn method
* fallback, which is just a branchless integer multiply, array element
* retrieval, and shift. The others, even if the function call overhead is
* optimized out, have to cope with the possibility of the input being all
* zeroes, and almost certainly will have conditionals for this eventuality.
* khw, at the time of this commit, looked at the source for both gcc and clang
* to verify this. (gcc used a method inferior to deBruijn.) */
/* Below are functions to find the first, last, or only set bit in a word. On
* platforms with 64-bit capability, there is a pair for each operation; the
* first taking a 64 bit operand, and the second a 32 bit one. The logic is
* the same in each pair, so the second is stripped of most comments. */
#ifdef U64TYPE /* HAS_QUAD not usable outside the core */
PERL_STATIC_INLINE unsigned
Perl_lsbit_pos64(U64 word)
{
/* Find the position (0..63) of the least significant set bit in the input
* word */
ASSUME(word != 0);
/* If we can determine that the platform has a usable fast method to get
* this info, use that */
# if defined(PERL_CTZ_64)
# define PERL_HAS_FAST_GET_LSB_POS64
return (unsigned) PERL_CTZ_64(word);
# elif U64SIZE == 8 && defined(_WIN64) && defined(_MSC_VER)
# define PERL_HAS_FAST_GET_LSB_POS64
{
unsigned long index;
_BitScanForward64(&index, word);
return (unsigned)index;
}
# else
/* Here, we didn't find a fast method for finding the lsb. Fall back to
* making the lsb the only set bit in the word, and use our function that
* works on words with a single bit set.
*
* Isolate the lsb;
* https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
*
* The word will look like this, with a rightmost set bit in position 's':
* ('x's are don't cares, and 'y's are their complements)
* s
* x..x100..00
* y..y011..11 Complement
* y..y100..00 Add 1
* 0..0100..00 And with the original
*
* (Yes, complementing and adding 1 is just taking the negative on 2's
* complement machines, but not on 1's complement ones, and some compilers
* complain about negating an unsigned.)
*/
return single_1bit_pos64(word & (~word + 1));
# endif
}
# define lsbit_pos_uintmax_(word) lsbit_pos64(word)
#else /* ! QUAD */
# define lsbit_pos_uintmax_(word) lsbit_pos32(word)
#endif
PERL_STATIC_INLINE unsigned /* Like above for 32 bit word */
Perl_lsbit_pos32(U32 word)
{
/* Find the position (0..31) of the least significant set bit in the input
* word */
ASSUME(word != 0);
#if defined(PERL_CTZ_32)
# define PERL_HAS_FAST_GET_LSB_POS32
return (unsigned) PERL_CTZ_32(word);
#elif U32SIZE == 4 && defined(_MSC_VER)
# define PERL_HAS_FAST_GET_LSB_POS32
{
unsigned long index;
_BitScanForward(&index, word);
return (unsigned)index;
}
#else
return single_1bit_pos32(word & (~word + 1));
#endif
}
/* Convert the leading zeros count to the bit position of the first set bit.
* This just subtracts from the highest position, 31 or 63. But some compilers
* don't optimize this optimally, and so a bit of bit twiddling encourages them
* to do the right thing. It turns out that subtracting a smaller non-negative
* number 'x' from 2**n-1 for any n is the same as taking the exclusive-or of
* the two numbers. To see why, first note that the sum of any number, x, and
* its complement, x', is all ones. So all ones minus x is x'. Then note that
* the xor of x and all ones is x'. */
#define LZC_TO_MSBIT_POS_(size, lzc) ((size##SIZE * CHARBITS - 1) ^ (lzc))
#ifdef U64TYPE /* HAS_QUAD not usable outside the core */
PERL_STATIC_INLINE unsigned
Perl_msbit_pos64(U64 word)
{
/* Find the position (0..63) of the most significant set bit in the input
* word */
ASSUME(word != 0);
/* If we can determine that the platform has a usable fast method to get
* this, use that */
# if defined(PERL_CLZ_64)
# define PERL_HAS_FAST_GET_MSB_POS64
return (unsigned) LZC_TO_MSBIT_POS_(U64, PERL_CLZ_64(word));
# elif U64SIZE == 8 && defined(_WIN64) && defined(_MSC_VER)
# define PERL_HAS_FAST_GET_MSB_POS64
{
unsigned long index;
_BitScanReverse64(&index, word);
return (unsigned)index;
}
# else
/* Here, we didn't find a fast method for finding the msb. Fall back to
* making the msb the only set bit in the word, and use our function that
* works on words with a single bit set.
*
* Isolate the msb; http://codeforces.com/blog/entry/10330
*
* Only the most significant set bit matters. Or'ing word with its right
* shift of 1 makes that bit and the next one to its right both 1.
* Repeating that with the right shift of 2 makes for 4 1-bits in a row.
* ... We end with the msb and all to the right being 1. */
word |= (word >> 1);
word |= (word >> 2);
word |= (word >> 4);
word |= (word >> 8);
word |= (word >> 16);
word |= (word >> 32);
/* Then subtracting the right shift by 1 clears all but the left-most of
* the 1 bits, which is our desired result */
word -= (word >> 1);
/* Now we have a single bit set */
return single_1bit_pos64(word);
# endif
}
# define msbit_pos_uintmax_(word) msbit_pos64(word)
#else /* ! QUAD */
# define msbit_pos_uintmax_(word) msbit_pos32(word)
#endif
PERL_STATIC_INLINE unsigned
Perl_msbit_pos32(U32 word)
{
/* Find the position (0..31) of the most significant set bit in the input
* word */
ASSUME(word != 0);
#if defined(PERL_CLZ_32)
# define PERL_HAS_FAST_GET_MSB_POS32
return (unsigned) LZC_TO_MSBIT_POS_(U32, PERL_CLZ_32(word));
#elif U32SIZE == 4 && defined(_MSC_VER)
# define PERL_HAS_FAST_GET_MSB_POS32
{
unsigned long index;
_BitScanReverse(&index, word);
return (unsigned)index;
}
#else
word |= (word >> 1);
word |= (word >> 2);
word |= (word >> 4);
word |= (word >> 8);
word |= (word >> 16);
word -= (word >> 1);
return single_1bit_pos32(word);
#endif
}
#if UVSIZE == U64SIZE
# define msbit_pos(word) msbit_pos64(word)
# define lsbit_pos(word) lsbit_pos64(word)
#elif UVSIZE == U32SIZE
# define msbit_pos(word) msbit_pos32(word)
# define lsbit_pos(word) lsbit_pos32(word)
#endif
#ifdef U64TYPE /* HAS_QUAD not usable outside the core */
PERL_STATIC_INLINE unsigned
Perl_single_1bit_pos64(U64 word)
{
/* Given a 64-bit word known to contain all zero bits except one 1 bit,
* find and return the 1's position: 0..63 */
# ifdef PERL_CORE /* macro not exported */
ASSUME(isPOWER_OF_2(word));
# else
ASSUME(word && (word & (word-1)) == 0);
# endif
/* The only set bit is both the most and least significant bit. If we have
* a fast way of finding either one, use that.
*
* It may appear at first glance that those functions call this one, but
* they don't if the corresponding #define is set */
# ifdef PERL_HAS_FAST_GET_MSB_POS64
return msbit_pos64(word);
# elif defined(PERL_HAS_FAST_GET_LSB_POS64)
return lsbit_pos64(word);
# else
/* The position of the only set bit in a word can be quickly calculated
* using deBruijn sequences. See for example
* https://en.wikipedia.org/wiki/De_Bruijn_sequence */
return PL_deBruijn_bitpos_tab64[(word * PERL_deBruijnMagic64_)
>> PERL_deBruijnShift64_];