1 /*
2 * %CopyrightBegin%
3 *
4 * Copyright Ericsson AB 1996-2021. All Rights Reserved.
5 *
6 * Licensed under the Apache License, Version 2.0 (the "License");
7 * you may not use this file except in compliance with the License.
8 * You may obtain a copy of the License at
9 *
10 * http://www.apache.org/licenses/LICENSE-2.0
11 *
12 * Unless required by applicable law or agreed to in writing, software
13 * distributed under the License is distributed on an "AS IS" BASIS,
14 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
15 * See the License for the specific language governing permissions and
16 * limitations under the License.
17 *
18 * %CopyrightEnd%
19 */
20
21 #ifdef HAVE_CONFIG_H
22 # include "config.h"
23 #endif
24
25 #include <stddef.h> /* offsetof() */
26 #include "sys.h"
27 #include "erl_vm.h"
28 #include "erl_sys_driver.h"
29 #include "global.h"
30 #include "erl_process.h"
31 #include "error.h"
32 #define ERL_WANT_HIPE_BIF_WRAPPER__
33 #include "bif.h"
34 #undef ERL_WANT_HIPE_BIF_WRAPPER__
35 #include "big.h"
36 #include "dist.h"
37 #include "erl_version.h"
38 #include "erl_binary.h"
39 #include "beam_bp.h"
40 #include "erl_db_util.h"
41 #include "register.h"
42 #include "erl_thr_progress.h"
43 #define ERTS_PTAB_WANT_BIF_IMPL__
44 #include "erl_ptab.h"
45 #include "erl_bits.h"
46 #include "erl_bif_unique.h"
47 #include "erl_map.h"
48 #include "erl_msacc.h"
49 #include "erl_proc_sig_queue.h"
50
51 Export *erts_await_result;
52 static Export await_exit_trap;
53 static Export* flush_monitor_messages_trap = NULL;
54 static Export* set_cpu_topology_trap = NULL;
55 static Export* await_port_send_result_trap = NULL;
56 Export* erts_format_cpu_topology_trap = NULL;
57 static Export dsend_continue_trap_export;
58 Export *erts_convert_time_unit_trap = NULL;
59
60 static Export *await_msacc_mod_trap = NULL;
61 static erts_atomic32_t msacc;
62
63 static Export *system_flag_scheduler_wall_time_trap;
64 static Export *await_sched_wall_time_mod_trap;
65 static erts_atomic32_t sched_wall_time;
66
67 #define DECL_AM(S) Eterm AM_ ## S = am_atom_put(#S, sizeof(#S) - 1)
68
69 /*
70 * The BIF's now follow, see the Erlang Manual for a description of what
71 * each individual BIF does.
72 */
73
spawn_3(BIF_ALIST_3)74 BIF_RETTYPE spawn_3(BIF_ALIST_3)
75 {
76 ErlSpawnOpts so;
77 Eterm pid;
78
79 so.flags = erts_default_spo_flags;
80 so.opts = NIL;
81 so.tag = am_spawn_reply;
82 pid = erl_create_process(BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3, &so);
83 if (is_non_value(pid)) {
84 BIF_ERROR(BIF_P, so.error_code);
85 } else {
86 if (ERTS_USE_MODIFIED_TIMING()) {
87 BIF_TRAP2(erts_delay_trap, BIF_P, pid, ERTS_MODIFIED_TIMING_DELAY);
88 }
89 BIF_RET(pid);
90 }
91 }
92
93 /**********************************************************************/
94
95 /* Utility to add a new link between processes p and another internal
96 * process (rpid). Process p must be the currently executing process.
97 */
98
99 /* create a link to the process */
link_1(BIF_ALIST_1)100 BIF_RETTYPE link_1(BIF_ALIST_1)
101 {
102 if (IS_TRACED_FL(BIF_P, F_TRACE_PROCS)) {
103 trace_proc(BIF_P, ERTS_PROC_LOCK_MAIN, BIF_P, am_link, BIF_ARG_1);
104 }
105 /* check that the pid or port which is our argument is OK */
106
107 if (is_internal_pid(BIF_ARG_1)) {
108 int created;
109 ErtsLink *lnk, *rlnk;
110
111 if (BIF_P->common.id == BIF_ARG_1)
112 BIF_RET(am_true);
113
114 if (!erts_proc_lookup(BIF_ARG_1))
115 goto res_no_proc;
116
117 lnk = erts_link_internal_tree_lookup_create(&ERTS_P_LINKS(BIF_P),
118 &created,
119 ERTS_LNK_TYPE_PROC,
120 BIF_ARG_1);
121 if (!created) {
122 ErtsILink *ilnk = (ErtsILink *) lnk;
123 if (!ilnk->unlinking)
124 BIF_RET(am_true);
125 ilnk->unlinking = 0;
126 }
127
128 rlnk = erts_link_internal_create(ERTS_LNK_TYPE_PROC, BIF_P->common.id);
129
130 if (erts_proc_sig_send_link(BIF_P, BIF_ARG_1, rlnk))
131 BIF_RET(am_true);
132
133 erts_link_tree_delete(&ERTS_P_LINKS(BIF_P), lnk);
134 erts_link_internal_release(lnk);
135 erts_link_internal_release(rlnk);
136 goto res_no_proc;
137 }
138
139 if (is_internal_port(BIF_ARG_1)) {
140 int created;
141 ErtsLink *lnk, *rlnk;
142 Eterm ref;
143 Eterm *refp;
144 Port *prt = erts_port_lookup(BIF_ARG_1,
145 (erts_port_synchronous_ops
146 ? ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP
147 : ERTS_PORT_SFLGS_INVALID_LOOKUP));
148 if (!prt)
149 goto res_no_proc;
150
151 lnk = erts_link_internal_tree_lookup_create(&ERTS_P_LINKS(BIF_P),
152 &created,
153 ERTS_LNK_TYPE_PORT,
154 BIF_ARG_1);
155 if (!created) {
156 ErtsILink *ilnk = (ErtsILink *) lnk;
157 if (!ilnk->unlinking)
158 BIF_RET(am_true);
159 ilnk->unlinking = 0;
160 }
161
162 rlnk = erts_link_internal_create(ERTS_LNK_TYPE_PROC, BIF_P->common.id);
163 refp = erts_port_synchronous_ops ? &ref : NULL;
164
165 switch (erts_port_link(BIF_P, prt, rlnk, refp)) {
166 case ERTS_PORT_OP_BADARG:
167 erts_link_internal_release(rlnk);
168 erts_link_tree_delete(&ERTS_P_LINKS(BIF_P), lnk);
169 erts_link_internal_release(lnk);
170 goto res_no_proc;
171 case ERTS_PORT_OP_DROPPED:
172 case ERTS_PORT_OP_SCHEDULED:
173 if (refp) {
174 ASSERT(is_internal_ordinary_ref(ref));
175 BIF_TRAP3(await_port_send_result_trap, BIF_P, ref, am_true, am_true);
176 }
177 default:
178 break;
179 }
180 BIF_RET(am_true);
181 }
182 else if (is_external_port(BIF_ARG_1)
183 && external_port_dist_entry(BIF_ARG_1) == erts_this_dist_entry) {
184 goto res_no_proc;
185 }
186
187 if (is_external_pid(BIF_ARG_1)) {
188 ErtsELink *elnk, *relnk, *pelnk;
189 int created, replace;
190 DistEntry *dep;
191 ErtsLink *lnk, *rlnk;
192 int code;
193 ErtsDSigSendContext ctx;
194
195 dep = external_pid_dist_entry(BIF_ARG_1);
196 if (dep == erts_this_dist_entry)
197 goto res_no_proc;
198
199 lnk = erts_link_external_tree_lookup_create(&ERTS_P_LINKS(BIF_P),
200 &created,
201 ERTS_LNK_TYPE_DIST_PROC,
202 BIF_P->common.id,
203 BIF_ARG_1);
204
205 elnk = erts_link_to_elink(lnk);
206
207 if (created) {
208 pelnk = NULL;
209 relnk = NULL;
210 rlnk = NULL;
211 }
212 else {
213 if (!elnk->unlinking)
214 BIF_RET(am_true); /* Already present... */
215 /*
216 * We need to replace the link if the connection has changed.
217 * Prepare a link...
218 */
219 pelnk = (ErtsELink *) erts_link_external_create(ERTS_LNK_TYPE_DIST_PROC,
220 BIF_P->common.id,
221 BIF_ARG_1);
222 ASSERT(eq(pelnk->ld.proc.other.item, BIF_ARG_1));
223 ASSERT(pelnk->ld.dist.other.item == BIF_P->common.id);
224 /* Release pelnk if not used as replacement... */
225 relnk = pelnk;
226 rlnk = &pelnk->ld.proc;
227 }
228 replace = 0;
229
230 ASSERT(eq(elnk->ld.proc.other.item, BIF_ARG_1));
231 ASSERT(elnk->ld.dist.other.item == BIF_P->common.id);
232
233 code = erts_dsig_prepare(&ctx, dep, BIF_P,
234 ERTS_PROC_LOCK_MAIN,
235 ERTS_DSP_RLOCK, 0, 1, 1);
236 switch (code) {
237 case ERTS_DSIG_PREP_NOT_ALIVE:
238 case ERTS_DSIG_PREP_NOT_CONNECTED:
239 if (created || elnk->unlinking) {
240 if (elnk->unlinking) {
241 /*
242 * Currently unlinking an old link from an old connection; replace
243 * old link with the prepared one...
244 */
245 relnk = NULL;
246 rlnk = lnk;
247 elnk = pelnk;
248 replace = !0;
249 }
250 erts_link_set_dead_dist(&elnk->ld.dist, dep->sysname);
251 }
252 erts_proc_sig_send_link_exit(NULL, THE_NON_VALUE, &elnk->ld.dist,
253 am_noconnection, NIL);
254 break;
255
256 case ERTS_DSIG_PREP_PENDING:
257 case ERTS_DSIG_PREP_CONNECTED: {
258 /*
259 * We have a connection (or a pending connection).
260 * Setup link and enqueue link signal.
261 */
262 if (created
263 || (elnk->unlinking
264 && elnk->dist->connection_id != ctx.connection_id)) {
265 int inserted;
266 if (!created) {
267 /*
268 * Currently unlinking an old link from an old connection; replace
269 * old link with the prepared one...
270 */
271 rlnk = lnk;
272 if (erts_link_dist_delete(&elnk->ld.dist))
273 relnk = elnk;
274 else
275 relnk = NULL;
276 elnk = pelnk;
277 replace = !0;
278 }
279 inserted = erts_link_dist_insert(&elnk->ld.dist, dep->mld);
280 ASSERT(inserted); (void)inserted;
281 }
282
283 erts_de_runlock(dep);
284
285 code = erts_dsig_send_link(&ctx, BIF_P->common.id, BIF_ARG_1);
286 if (code == ERTS_DSIG_SEND_YIELD)
287 ERTS_BIF_YIELD_RETURN(BIF_P, am_true);
288 ASSERT(code == ERTS_DSIG_SEND_OK);
289 break;
290 }
291 default:
292 ERTS_ASSERT(! "Invalid dsig prepare result");
293 }
294
295 if (replace) {
296 ASSERT(pelnk);
297 erts_link_tree_replace(&ERTS_P_LINKS(BIF_P), rlnk, &pelnk->ld.proc);
298 }
299
300 if (relnk)
301 erts_link_release_both(&relnk->ld);
302 else if (rlnk)
303 erts_link_release(rlnk);
304
305 elnk->unlinking = 0;
306
307 BIF_RET(am_true);
308 }
309
310 BIF_ERROR(BIF_P, BADARG);
311
312 res_no_proc:
313 if (BIF_P->flags & F_TRAP_EXIT) {
314 ErtsProcLocks locks = ERTS_PROC_LOCK_MAIN;
315 erts_deliver_exit_message(BIF_ARG_1, BIF_P, &locks, am_noproc, NIL);
316 erts_proc_unlock(BIF_P, ~ERTS_PROC_LOCK_MAIN & locks);
317 BIF_RET(am_true);
318 }
319 else {
320 /*
321 * This behaviour is *really* sad but link/1 has
322 * behaved like this for ages (and this behaviour is
323 * actually documented)... :'-(
324 *
325 * The proper behavior would have been to
326 * send calling process an exit signal..
327 */
328 BIF_ERROR(BIF_P, EXC_NOPROC);
329 }
330 }
331
332 static Eterm
demonitor(Process * c_p,Eterm ref,Eterm * multip)333 demonitor(Process *c_p, Eterm ref, Eterm *multip)
334 {
335 ErtsMonitor *mon; /* The monitor entry to delete */
336
337 *multip = am_false;
338
339 if (is_not_internal_ref(ref)) {
340 if (is_external_ref(ref)
341 && (erts_this_dist_entry
342 == external_ref_dist_entry(ref))) {
343 return am_false;
344 }
345 return am_badarg; /* Not monitored by this monitor's ref */
346 }
347
348 mon = erts_monitor_tree_lookup(ERTS_P_MONITORS(c_p), ref);
349 if (!mon)
350 return am_false;
351
352 if (!erts_monitor_is_origin(mon))
353 return am_badarg;
354
355 erts_monitor_tree_delete(&ERTS_P_MONITORS(c_p), mon);
356
357 switch (mon->type) {
358
359 case ERTS_MON_TYPE_TIME_OFFSET:
360 *multip = am_true;
361 erts_demonitor_time_offset(mon);
362 return am_true;
363
364 case ERTS_MON_TYPE_PORT: {
365 Port *prt;
366 ASSERT(is_internal_port(mon->other.item));
367 prt = erts_port_lookup(mon->other.item, ERTS_PORT_SFLGS_DEAD);
368 if (!prt || erts_port_demonitor(c_p, prt, mon) == ERTS_PORT_OP_DROPPED)
369 erts_monitor_release(mon);
370 return am_true;
371 }
372
373 case ERTS_MON_TYPE_PROC:
374 erts_proc_sig_send_demonitor(mon);
375 return am_true;
376
377 case ERTS_MON_TYPE_DIST_PROC: {
378 ErtsMonitorData *mdp = erts_monitor_to_data(mon);
379 Eterm to = mon->other.item;
380 DistEntry *dep;
381 int code = ERTS_DSIG_SEND_OK;
382 int deleted;
383 ErtsDSigSendContext ctx;
384
385 if (mon->flags & ERTS_ML_FLG_SPAWN_PENDING) {
386 /*
387 * Not allowed to remove this until spawn
388 * operation has succeeded; restore monitor...
389 */
390 erts_monitor_tree_insert(&ERTS_P_MONITORS(c_p), mon);
391 return am_false;
392 }
393
394 ASSERT(is_external_pid(to) || is_node_name_atom(to));
395
396 if (is_external_pid(to))
397 dep = external_pid_dist_entry(to);
398 else {
399 /* Monitoring a name at node to */
400 dep = erts_sysname_to_connected_dist_entry(to);
401 ASSERT(dep != erts_this_dist_entry);
402 if (!dep) {
403 erts_monitor_release(mon);
404 return am_false;
405 }
406 }
407
408 code = erts_dsig_prepare(&ctx, dep, c_p, ERTS_PROC_LOCK_MAIN,
409 ERTS_DSP_RLOCK, 0, 1, 0);
410
411 deleted = erts_monitor_dist_delete(&mdp->target);
412
413 switch (code) {
414 case ERTS_DSIG_PREP_NOT_ALIVE:
415 case ERTS_DSIG_PREP_NOT_CONNECTED:
416 /*
417 * In the smp case this is possible if the node goes
418 * down just before the call to demonitor.
419 */
420 break;
421
422 case ERTS_DSIG_PREP_PENDING:
423 case ERTS_DSIG_PREP_CONNECTED: {
424 Eterm watched;
425
426 erts_de_runlock(dep);
427
428 if (mon->flags & ERTS_ML_FLG_NAME)
429 watched = ((ErtsMonitorDataExtended *) mdp)->u.name;
430 else
431 watched = to;
432
433 /*
434 * Soft (no force) send, use ->data in dist slot
435 * monitor list since in case of monitor name
436 * the atom is stored there. Yield if necessary.
437 */
438 code = erts_dsig_send_demonitor(&ctx, c_p->common.id,
439 watched, mdp->ref);
440 break;
441 }
442
443 default:
444 ERTS_INTERNAL_ERROR("invalid result from erts_dsig_prepare()");
445 break;
446 }
447
448 if (deleted)
449 erts_monitor_release(&mdp->target);
450
451 erts_monitor_release(mon);
452 return code == ERTS_DSIG_SEND_YIELD ? am_yield : am_true;
453 }
454
455 default:
456 ERTS_INTERNAL_ERROR("Unexpected monitor type");
457 return am_false;
458 }
459 }
460
demonitor_1(BIF_ALIST_1)461 BIF_RETTYPE demonitor_1(BIF_ALIST_1)
462 {
463 Eterm multi;
464 switch (demonitor(BIF_P, BIF_ARG_1, &multi)) {
465 case am_false:
466 case am_true:
467 BIF_RET(am_true);
468 case am_yield:
469 ERTS_BIF_YIELD_RETURN(BIF_P, am_true);
470 case am_badarg:
471 default:
472 BIF_ERROR(BIF_P, BADARG);
473 }
474 }
475
demonitor_2(BIF_ALIST_2)476 BIF_RETTYPE demonitor_2(BIF_ALIST_2)
477 {
478 BIF_RETTYPE res;
479 Eterm multi = am_false;
480 int info = 0;
481 int flush = 0;
482 Eterm list = BIF_ARG_2;
483
484 while (is_list(list)) {
485 Eterm* consp = list_val(list);
486 switch (CAR(consp)) {
487 case am_flush:
488 flush = 1;
489 break;
490 case am_info:
491 info = 1;
492 break;
493 default:
494 goto badarg;
495 }
496 list = CDR(consp);
497 }
498
499 if (is_not_nil(list))
500 goto badarg;
501
502 res = am_true;
503 switch (demonitor(BIF_P, BIF_ARG_1, &multi)) {
504
505 case am_false:
506 if (info)
507 res = am_false;
508 if (flush) {
509 flush_messages:
510 BIF_TRAP3(flush_monitor_messages_trap, BIF_P,
511 BIF_ARG_1, multi, res);
512 }
513 /* Fall through... */
514
515 case am_true:
516 if (multi == am_true && flush)
517 goto flush_messages;
518 BIF_RET(res);
519
520 case am_yield:
521 /* return true after yield... */
522 if (flush) {
523 ERTS_VBUMP_ALL_REDS(BIF_P);
524 goto flush_messages;
525 }
526 ERTS_BIF_YIELD_RETURN(BIF_P, am_true);
527
528 case am_badarg:
529 default:
530 break;
531
532 }
533
534 badarg:
535 BIF_ERROR(BIF_P, BADARG);
536 }
537
538 /* Type must be atomic object! */
539 void
erts_queue_monitor_message(Process * p,ErtsProcLocks * p_locksp,Eterm ref,Eterm type,Eterm item,Eterm reason)540 erts_queue_monitor_message(Process *p,
541 ErtsProcLocks *p_locksp,
542 Eterm ref,
543 Eterm type,
544 Eterm item,
545 Eterm reason)
546 {
547 Eterm tup;
548 Eterm* hp;
549 Eterm reason_copy, ref_copy, item_copy;
550 Uint reason_size, ref_size, item_size, heap_size;
551 ErlOffHeap *ohp;
552 ErtsMessage *msgp;
553
554 reason_size = IS_CONST(reason) ? 0 : size_object(reason);
555 item_size = IS_CONST(item) ? 0 : size_object(item);
556 ref_size = size_object(ref);
557
558 heap_size = 6+reason_size+ref_size+item_size;
559
560 msgp = erts_alloc_message_heap(p, p_locksp, heap_size,
561 &hp, &ohp);
562
563 reason_copy = (IS_CONST(reason)
564 ? reason
565 : copy_struct(reason, reason_size, &hp, ohp));
566 item_copy = (IS_CONST(item)
567 ? item
568 : copy_struct(item, item_size, &hp, ohp));
569 ref_copy = copy_struct(ref, ref_size, &hp, ohp);
570
571 tup = TUPLE5(hp, am_DOWN, ref_copy, type, item_copy, reason_copy);
572 erts_queue_message(p, *p_locksp, msgp, tup, am_system);
573 }
574
monitor_2(BIF_ALIST_2)575 BIF_RETTYPE monitor_2(BIF_ALIST_2)
576 {
577 Eterm target = BIF_ARG_2;
578 Eterm tmp_heap[3];
579 Eterm ref, id, name;
580 ErtsMonitorData *mdp;
581
582 if (BIF_ARG_1 == am_process) {
583 DistEntry *dep;
584 int byname;
585
586 if (is_internal_pid(target)) {
587 name = NIL;
588 id = target;
589
590 local_process:
591
592 ref = erts_make_ref(BIF_P);
593 if (id != BIF_P->common.id) {
594 mdp = erts_monitor_create(ERTS_MON_TYPE_PROC,
595 ref, BIF_P->common.id,
596 id, name);
597 erts_monitor_tree_insert(&ERTS_P_MONITORS(BIF_P),
598 &mdp->origin);
599
600 if (!erts_proc_sig_send_monitor(&mdp->target, id))
601 erts_proc_sig_send_monitor_down(&mdp->target,
602 am_noproc);
603 }
604 BIF_RET(ref);
605 }
606
607 if (is_atom(target)) {
608 local_named_process:
609 name = target;
610 id = erts_whereis_name_to_id(BIF_P, target);
611 if (is_internal_pid(id))
612 goto local_process;
613 target = TUPLE2(&tmp_heap[0], name,
614 erts_this_dist_entry->sysname);
615 goto noproc;
616 }
617
618 if (is_external_pid(target)) {
619 ErtsDSigSendContext ctx;
620 int code;
621
622 dep = external_pid_dist_entry(target);
623 if (dep == erts_this_dist_entry)
624 goto noproc;
625
626 id = target;
627 name = NIL;
628 byname = 0;
629
630 remote_process:
631
632 ref = erts_make_ref(BIF_P);
633 mdp = erts_monitor_create(ERTS_MON_TYPE_DIST_PROC, ref,
634 BIF_P->common.id, id, name);
635 erts_monitor_tree_insert(&ERTS_P_MONITORS(BIF_P), &mdp->origin);
636
637 code = erts_dsig_prepare(&ctx, dep,
638 BIF_P, ERTS_PROC_LOCK_MAIN,
639 ERTS_DSP_RLOCK, 0, 1, 1);
640 switch (code) {
641 case ERTS_DSIG_PREP_NOT_ALIVE:
642 case ERTS_DSIG_PREP_NOT_CONNECTED:
643 erts_monitor_set_dead_dist(&mdp->target, dep->sysname);
644 erts_proc_sig_send_monitor_down(&mdp->target, am_noconnection);
645 code = ERTS_DSIG_SEND_OK;
646 break;
647
648 case ERTS_DSIG_PREP_PENDING:
649 case ERTS_DSIG_PREP_CONNECTED: {
650 int inserted = erts_monitor_dist_insert(&mdp->target, dep->mld);
651 ASSERT(inserted); (void)inserted;
652 erts_de_runlock(dep);
653
654 code = erts_dsig_send_monitor(&ctx, BIF_P->common.id, target, ref);
655 break;
656 }
657
658 default:
659 ERTS_ASSERT(! "Invalid dsig prepare result");
660 code = ERTS_DSIG_SEND_OK;
661 break;
662 }
663
664 if (byname)
665 erts_deref_dist_entry(dep);
666
667 if (code == ERTS_DSIG_SEND_YIELD)
668 ERTS_BIF_YIELD_RETURN(BIF_P, ref);
669 BIF_RET(ref);
670 }
671
672 if (is_tuple(target)) {
673 Eterm *tpl = tuple_val(target);
674 if (arityval(tpl[0]) != 2)
675 goto badarg;
676 if (is_not_atom(tpl[1]) || is_not_atom(tpl[2]))
677 goto badarg;
678 if (!erts_is_alive && tpl[2] != am_Noname)
679 goto badarg;
680 target = tpl[1];
681 dep = erts_find_or_insert_dist_entry(tpl[2]);
682 if (dep == erts_this_dist_entry) {
683 erts_deref_dist_entry(dep);
684 goto local_named_process;
685 }
686
687 id = dep->sysname;
688 name = target;
689 byname = 1;
690 goto remote_process;
691 }
692
693 /* badarg... */
694 }
695 else if (BIF_ARG_1 == am_port) {
696
697 if (is_internal_port(target)) {
698 Port *prt;
699 name = NIL;
700 id = target;
701 local_port:
702 ref = erts_make_ref(BIF_P);
703 mdp = erts_monitor_create(ERTS_MON_TYPE_PORT, ref,
704 BIF_P->common.id, id, name);
705 erts_monitor_tree_insert(&ERTS_P_MONITORS(BIF_P), &mdp->origin);
706 prt = erts_port_lookup(id, ERTS_PORT_SFLGS_INVALID_LOOKUP);
707 if (!prt || erts_port_monitor(BIF_P, prt, &mdp->target) == ERTS_PORT_OP_DROPPED)
708 erts_proc_sig_send_monitor_down(&mdp->target, am_noproc);
709 BIF_RET(ref);
710 }
711
712 if (is_atom(target)) {
713 local_named_port:
714 name = target;
715 id = erts_whereis_name_to_id(BIF_P, target);
716 if (is_internal_port(id))
717 goto local_port;
718 target = TUPLE2(&tmp_heap[0], name,
719 erts_this_dist_entry->sysname);
720 goto noproc;
721 }
722
723 if (is_external_port(target)) {
724 if (erts_this_dist_entry == external_port_dist_entry(target))
725 goto noproc;
726 goto badarg;
727 }
728
729 if (is_tuple(target)) {
730 Eterm *tpl = tuple_val(target);
731 if (arityval(tpl[0]) != 2)
732 goto badarg;
733 if (is_not_atom(tpl[1]) || is_not_atom(tpl[2]))
734 goto badarg;
735 if (tpl[2] == erts_this_dist_entry->sysname) {
736 target = tpl[1];
737 goto local_named_port;
738 }
739 }
740
741 /* badarg... */
742 }
743 else if (BIF_ARG_1 == am_time_offset) {
744
745 if (target != am_clock_service)
746 goto badarg;
747 ref = erts_make_ref(BIF_P);
748 mdp = erts_monitor_create(ERTS_MON_TYPE_TIME_OFFSET,
749 ref, BIF_P->common.id,
750 am_clock_service, NIL);
751 erts_monitor_tree_insert(&ERTS_P_MONITORS(BIF_P), &mdp->origin);
752
753 erts_monitor_time_offset(&mdp->target);
754
755 BIF_RET(ref);
756 }
757
758 badarg:
759
760 BIF_ERROR(BIF_P, BADARG);
761
762 noproc: {
763 ErtsProcLocks locks = ERTS_PROC_LOCK_MAIN;
764
765 ref = erts_make_ref(BIF_P);
766 erts_queue_monitor_message(BIF_P,
767 &locks,
768 ref,
769 BIF_ARG_1,
770 target,
771 am_noproc);
772 if (locks != ERTS_PROC_LOCK_MAIN)
773 erts_proc_unlock(BIF_P, locks & ~ERTS_PROC_LOCK_MAIN);
774
775 BIF_RET(ref);
776 }
777 }
778
779 /**********************************************************************/
780 /* this is a combination of the spawn and link BIFs */
781
spawn_link_3(BIF_ALIST_3)782 BIF_RETTYPE spawn_link_3(BIF_ALIST_3)
783 {
784 ErlSpawnOpts so;
785 Eterm pid;
786 Eterm tmp_heap[2];
787
788 so.flags = erts_default_spo_flags|SPO_LINK;
789 so.opts = CONS(&tmp_heap[0], am_link, NIL);
790 so.tag = am_spawn_reply;
791 pid = erl_create_process(BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3, &so);
792 if (is_non_value(pid)) {
793 BIF_ERROR(BIF_P, so.error_code);
794 } else {
795 if (ERTS_USE_MODIFIED_TIMING()) {
796 BIF_TRAP2(erts_delay_trap, BIF_P, pid, ERTS_MODIFIED_TIMING_DELAY);
797 }
798 BIF_RET(pid);
799 }
800 }
801
802 /**********************************************************************/
803
spawn_opt_4(BIF_ALIST_4)804 BIF_RETTYPE spawn_opt_4(BIF_ALIST_4)
805 {
806 ErlSpawnOpts so;
807 Eterm pid;
808 Eterm res;
809 int opts_error;
810
811 /*
812 * Fail order:
813 * - Bad types
814 * - Bad options
815 */
816 opts_error = erts_parse_spawn_opts(&so, BIF_ARG_4, NULL, 0);
817 if (opts_error) {
818 Sint arity;
819 if (is_not_atom(BIF_ARG_1) || is_not_atom(BIF_ARG_2))
820 BIF_ERROR(BIF_P, BADARG);
821 arity = erts_list_length(BIF_ARG_3);
822 if (arity < 0)
823 BIF_ERROR(BIF_P, BADARG);
824 if (arity > MAX_SMALL)
825 BIF_ERROR(BIF_P, SYSTEM_LIMIT);
826 if (opts_error > 0)
827 BIF_ERROR(BIF_P, BADARG);
828 BIF_ERROR(BIF_P, BADARG);
829 }
830
831 /*
832 * Spawn the process.
833 */
834 so.opts = BIF_ARG_4;
835 so.tag = am_spawn_reply;
836 pid = erl_create_process(BIF_P, BIF_ARG_1, BIF_ARG_2, BIF_ARG_3, &so);
837 if (is_non_value(pid)) {
838 BIF_ERROR(BIF_P, so.error_code);
839 } else if (so.flags & SPO_MONITOR) {
840 Eterm* hp = HAlloc(BIF_P, 3);
841 res = TUPLE2(hp, pid, so.mref);
842 } else {
843 res = pid;
844 }
845
846 if (ERTS_USE_MODIFIED_TIMING()) {
847 BIF_TRAP2(erts_delay_trap, BIF_P, res, ERTS_MODIFIED_TIMING_DELAY);
848 }
849 else {
850 BIF_RET(res);
851 }
852 }
853
854 /**********************************************************************/
855
erts_internal_spawn_request_4(BIF_ALIST_4)856 BIF_RETTYPE erts_internal_spawn_request_4(BIF_ALIST_4)
857 {
858 ErlSpawnOpts so;
859 Eterm tmp_heap_mfna[4];
860 Eterm tmp_heap_alist[4 + 2];
861 Sint arity;
862 int opts_error;
863 Eterm tag, tmp, error;
864
865 if (!is_atom(BIF_ARG_1))
866 goto badarg;
867 if (!is_atom(BIF_ARG_2))
868 goto badarg;
869 arity = erts_list_length(BIF_ARG_3);
870 if (arity < 0)
871 goto badarg;
872
873 /*
874 * Fail order:
875 * - Bad types
876 * - Bad options
877 */
878 opts_error = erts_parse_spawn_opts(&so, BIF_ARG_4, &tag, !0);
879 if (arity > MAX_SMALL)
880 goto system_limit;
881 if (opts_error) {
882 if (opts_error > 0)
883 goto badarg;
884 goto badopt;
885 }
886
887 /* Make argument list for erts_internal:spawn_init/1 */
888 tmp = TUPLE3(&tmp_heap_alist[0], BIF_ARG_1, BIF_ARG_2, BIF_ARG_3);
889 tmp = CONS(&tmp_heap_alist[4], tmp, NIL);
890
891 so.mfa = TUPLE3(&tmp_heap_mfna[0], BIF_ARG_1, BIF_ARG_2, make_small(arity));
892 so.flags |= SPO_ASYNC;
893 so.mref = THE_NON_VALUE;
894 so.tag = tag;
895 so.opts = BIF_ARG_4;
896
897 /*
898 * Spawn the process.
899 */
900 tmp = erl_create_process(BIF_P, am_erts_internal, am_spawn_init, tmp, &so);
901 if (is_non_value(tmp)) {
902 switch (so.error_code) {
903 case SYSTEM_LIMIT:
904 goto system_limit;
905 case BADARG:
906 default:
907 ERTS_INTERNAL_ERROR("Unexpected error from erl_create_process()");
908 BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR);
909 }
910 }
911
912 ASSERT(is_internal_pid(tmp));
913
914 if (ERTS_USE_MODIFIED_TIMING()) {
915 BIF_TRAP2(erts_delay_trap, BIF_P, so.mref, ERTS_MODIFIED_TIMING_DELAY);
916 }
917 else {
918 BIF_RET(so.mref);
919 }
920
921 badarg:
922 BIF_RET(am_badarg);
923 system_limit:
924 error = am_system_limit;
925 goto send_error;
926 badopt:
927 error = am_badopt;
928 /* fall through... */
929 send_error: {
930 Eterm ref = erts_make_ref(BIF_P);
931 if (!(so.flags & SPO_NO_EMSG))
932 erts_send_local_spawn_reply(BIF_P, ERTS_PROC_LOCK_MAIN, NULL,
933 tag, ref, error, am_undefined);
934 BIF_RET(ref);
935 }
936
937 }
938
spawn_request_abandon_1(BIF_ALIST_1)939 BIF_RETTYPE spawn_request_abandon_1(BIF_ALIST_1)
940 {
941 ErtsMonitor *omon;
942
943 if (is_not_internal_ref(BIF_ARG_1)) {
944 if (is_not_ref(BIF_ARG_1))
945 BIF_ERROR(BIF_P, BADARG);
946 /* Not an outstanding spawn_request of this process... */
947 BIF_RET(am_false);
948 }
949
950 omon = erts_monitor_tree_lookup(ERTS_P_MONITORS(BIF_P), BIF_ARG_1);
951 if (!omon
952 || ((omon->flags & (ERTS_ML_FLG_SPAWN_PENDING
953 | ERTS_ML_FLG_SPAWN_ABANDONED))
954 != ERTS_ML_FLG_SPAWN_PENDING)) {
955 /* Not an outstanding spawn_request of this process... */
956 BIF_RET(am_false);
957 }
958
959 ASSERT(erts_monitor_is_origin(omon));
960
961 if (omon->flags & ERTS_ML_FLG_SPAWN_LINK) {
962 /* Leave it for reply... */
963 omon->flags |= ERTS_ML_FLG_SPAWN_ABANDONED;
964 }
965 else {
966 /* We don't need it anymore; remove it... */
967 ErtsMonitorData *mdp;
968 erts_monitor_tree_delete(&ERTS_P_MONITORS(BIF_P), omon);
969 mdp = erts_monitor_to_data(omon);
970 if (erts_monitor_dist_delete(&mdp->target))
971 erts_monitor_release_both(mdp);
972 else
973 erts_monitor_release(omon);
974 }
975 BIF_RET(am_true);
976 }
977
978
979 /**********************************************************************/
980 /* remove a link from a process */
unlink_1(BIF_ALIST_1)981 BIF_RETTYPE unlink_1(BIF_ALIST_1)
982 {
983 if (IS_TRACED_FL(BIF_P, F_TRACE_PROCS)) {
984 trace_proc(BIF_P, ERTS_PROC_LOCK_MAIN,
985 BIF_P, am_unlink, BIF_ARG_1);
986 }
987
988 if (is_internal_pid(BIF_ARG_1)) {
989 ErtsILink *ilnk;
990 ilnk = (ErtsILink *) erts_link_tree_lookup(ERTS_P_LINKS(BIF_P),
991 BIF_ARG_1);
992 if (ilnk && !ilnk->unlinking) {
993 Uint64 id = erts_proc_sig_send_unlink(BIF_P,
994 BIF_P->common.id,
995 &ilnk->link);
996 if (id)
997 ilnk->unlinking = id;
998 else {
999 erts_link_tree_delete(&ERTS_P_LINKS(BIF_P), &ilnk->link);
1000 erts_link_internal_release(&ilnk->link);
1001 }
1002 }
1003 BIF_RET(am_true);
1004 }
1005
1006 if (is_internal_port(BIF_ARG_1)) {
1007 ErtsILink *ilnk;
1008 ilnk = (ErtsILink *) erts_link_tree_lookup(ERTS_P_LINKS(BIF_P),
1009 BIF_ARG_1);
1010
1011 if (ilnk && !ilnk->unlinking) {
1012 Eterm ref;
1013 Eterm *refp = erts_port_synchronous_ops ? &ref : NULL;
1014 ErtsPortOpResult res = ERTS_PORT_OP_DROPPED;
1015 Port *prt;
1016
1017 /* Send unlink signal */
1018 prt = erts_port_lookup(BIF_ARG_1, ERTS_PORT_SFLGS_DEAD);
1019 if (!prt) {
1020 erts_link_tree_delete(&ERTS_P_LINKS(BIF_P), &ilnk->link);
1021 erts_link_internal_release(&ilnk->link);
1022 }
1023 else {
1024 ErtsSigUnlinkOp *sulnk;
1025
1026 sulnk = erts_proc_sig_make_unlink_op(BIF_P, BIF_P->common.id);
1027 ilnk->unlinking = sulnk->id;
1028 #ifdef DEBUG
1029 ref = NIL;
1030 #endif
1031 res = erts_port_unlink(BIF_P, prt, sulnk, refp);
1032 }
1033
1034 if (refp && res == ERTS_PORT_OP_SCHEDULED) {
1035 ASSERT(is_internal_ordinary_ref(ref));
1036 BIF_TRAP3(await_port_send_result_trap, BIF_P, ref, am_true, am_true);
1037 }
1038 }
1039
1040 BIF_RET(am_true);
1041 }
1042
1043 if (is_external_pid(BIF_ARG_1)) {
1044 ErtsLink *lnk;
1045 ErtsELink *elnk;
1046 DistEntry *dep;
1047 Uint64 unlink_id;
1048 int code;
1049 ErtsDSigSendContext ctx;
1050
1051 dep = external_pid_dist_entry(BIF_ARG_1);
1052 if (dep == erts_this_dist_entry)
1053 BIF_RET(am_true);
1054
1055 lnk = erts_link_tree_lookup(ERTS_P_LINKS(BIF_P), BIF_ARG_1);
1056 if (!lnk)
1057 BIF_RET(am_true);
1058
1059 elnk = erts_link_to_elink(lnk);
1060
1061 if (elnk->unlinking)
1062 BIF_RET(am_true);
1063
1064 unlink_id = erts_proc_sig_new_unlink_id(BIF_P);
1065 elnk->unlinking = unlink_id;
1066
1067 code = erts_dsig_prepare(&ctx, dep, BIF_P, ERTS_PROC_LOCK_MAIN,
1068 ERTS_DSP_NO_LOCK, 0, 1, 0);
1069 switch (code) {
1070 case ERTS_DSIG_PREP_NOT_ALIVE:
1071 case ERTS_DSIG_PREP_NOT_CONNECTED:
1072 BIF_RET(am_true);
1073 case ERTS_DSIG_PREP_PENDING:
1074 case ERTS_DSIG_PREP_CONNECTED:
1075 /*
1076 * Do not send unlink signal on another connection than
1077 * the one which the link was set up on.
1078 */
1079 if (elnk->dist->connection_id == ctx.connection_id) {
1080 code = erts_dsig_send_unlink(&ctx, BIF_P->common.id, BIF_ARG_1,
1081 unlink_id);
1082 if (code == ERTS_DSIG_SEND_YIELD)
1083 ERTS_BIF_YIELD_RETURN(BIF_P, am_true);
1084 }
1085 break;
1086 default:
1087 ASSERT(! "Invalid dsig prepare result");
1088 BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR);
1089 }
1090
1091 BIF_RET(am_true);
1092 }
1093
1094 if (is_external_port(BIF_ARG_1)) {
1095 if (external_port_dist_entry(BIF_ARG_1) == erts_this_dist_entry)
1096 BIF_RET(am_true);
1097 /* Links to Remote ports not supported... */
1098 }
1099
1100 BIF_ERROR(BIF_P, BADARG);
1101 }
1102
hibernate_3(BIF_ALIST_3)1103 BIF_RETTYPE hibernate_3(BIF_ALIST_3)
1104 {
1105 /*
1106 * hibernate/3 is usually translated to an instruction; therefore
1107 * this function is only called from HiPE or when the call could not
1108 * be translated.
1109 */
1110 Eterm reg[3];
1111
1112 reg[0] = BIF_ARG_1;
1113 reg[1] = BIF_ARG_2;
1114 reg[2] = BIF_ARG_3;
1115
1116 if (erts_hibernate(BIF_P, reg)) {
1117 /*
1118 * If hibernate succeeded, TRAP. The process will be wait in a
1119 * hibernated state if its state is inactive (!ERTS_PSFLG_ACTIVE);
1120 * otherwise, continue executing (if any message was in the queue).
1121 */
1122 BIF_TRAP_CODE_PTR_(BIF_P, BIF_P->i);
1123 }
1124 return THE_NON_VALUE;
1125 }
1126
1127 /**********************************************************************/
1128
get_stacktrace_0(BIF_ALIST_0)1129 BIF_RETTYPE get_stacktrace_0(BIF_ALIST_0)
1130 {
1131 BIF_RET(NIL);
1132 }
1133
1134 /**********************************************************************/
1135 /*
1136 * This is like exit/1, except that errors are logged if they terminate
1137 * the process, and the final error value will be {Term,StackTrace}.
1138 */
1139
error_1(BIF_ALIST_1)1140 BIF_RETTYPE error_1(BIF_ALIST_1)
1141 {
1142 BIF_P->fvalue = BIF_ARG_1;
1143 BIF_ERROR(BIF_P, EXC_ERROR);
1144 }
1145
1146 /**********************************************************************/
1147 /*
1148 * This is like error/1, except that the given 'args' will be included
1149 * in the stacktrace.
1150 */
1151
error_2(BIF_ALIST_2)1152 BIF_RETTYPE error_2(BIF_ALIST_2)
1153 {
1154 Eterm* hp = HAlloc(BIF_P, 3);
1155
1156 BIF_P->fvalue = TUPLE2(hp, BIF_ARG_1, BIF_ARG_2);
1157 BIF_ERROR(BIF_P, EXC_ERROR_2);
1158 }
1159
1160 /**********************************************************************/
1161 /*
1162 * This is like exactly like error/1. The only difference is
1163 * that Dialyzer thinks that it it will return an arbitrary term.
1164 * It is useful in stub functions for NIFs.
1165 */
1166
nif_error_1(BIF_ALIST_1)1167 BIF_RETTYPE nif_error_1(BIF_ALIST_1)
1168 {
1169 BIF_P->fvalue = BIF_ARG_1;
1170 BIF_ERROR(BIF_P, EXC_ERROR);
1171 }
1172
1173 /**********************************************************************/
1174 /*
1175 * This is like exactly like error/2. The only difference is
1176 * that Dialyzer thinks that it it will return an arbitrary term.
1177 * It is useful in stub functions for NIFs.
1178 */
1179
nif_error_2(BIF_ALIST_2)1180 BIF_RETTYPE nif_error_2(BIF_ALIST_2)
1181 {
1182 Eterm* hp = HAlloc(BIF_P, 3);
1183
1184 BIF_P->fvalue = TUPLE2(hp, BIF_ARG_1, BIF_ARG_2);
1185 BIF_ERROR(BIF_P, EXC_ERROR_2);
1186 }
1187
1188 /**********************************************************************/
1189 /* this is like throw/1 except that we set freason to EXC_EXIT */
1190
exit_1(BIF_ALIST_1)1191 BIF_RETTYPE exit_1(BIF_ALIST_1)
1192 {
1193 BIF_P->fvalue = BIF_ARG_1; /* exit value */
1194 BIF_ERROR(BIF_P, EXC_EXIT);
1195 }
1196
1197
1198 /**********************************************************************/
1199 /* raise an exception of given class, value and stacktrace.
1200 *
1201 * If there is an error in the argument format,
1202 * return the atom 'badarg' instead.
1203 */
raise_3(BIF_ALIST_3)1204 BIF_RETTYPE raise_3(BIF_ALIST_3)
1205 {
1206 Process *c_p = BIF_P;
1207 Eterm class = BIF_ARG_1;
1208 Eterm value = BIF_ARG_2;
1209 Eterm stacktrace = BIF_ARG_3;
1210 Eterm reason;
1211 Eterm l, *hp, *hp_end, *tp;
1212 int depth, cnt;
1213 size_t sz;
1214 int must_copy = 0;
1215 struct StackTrace *s;
1216
1217 if (class == am_error) {
1218 c_p->fvalue = value;
1219 reason = EXC_ERROR;
1220 } else if (class == am_exit) {
1221 c_p->fvalue = value;
1222 reason = EXC_EXIT;
1223 } else if (class == am_throw) {
1224 c_p->fvalue = value;
1225 reason = EXC_THROWN;
1226 } else goto error;
1227 reason &= ~EXF_SAVETRACE;
1228
1229 /* Check syntax of stacktrace, and count depth.
1230 * Accept anything that can be returned from erlang:get_stacktrace/0,
1231 * as well as a 2-tuple with a fun as first element that the
1232 * error_handler may need to give us. Also allow old-style
1233 * MFA three-tuples.
1234 */
1235 for (l = stacktrace, depth = 0;
1236 is_list(l);
1237 l = CDR(list_val(l)), depth++) {
1238 Eterm t = CAR(list_val(l));
1239 Eterm location = NIL;
1240
1241 if (is_not_tuple(t)) goto error;
1242 tp = tuple_val(t);
1243 switch (arityval(tp[0])) {
1244 case 2:
1245 /* {Fun,Args} */
1246 if (is_fun(tp[1])) {
1247 must_copy = 1;
1248 } else {
1249 goto error;
1250 }
1251 break;
1252 case 3:
1253 /*
1254 * One of:
1255 * {Fun,Args,Location}
1256 * {M,F,A}
1257 */
1258 if (is_fun(tp[1])) {
1259 location = tp[3];
1260 } else if (is_atom(tp[1]) && is_atom(tp[2])) {
1261 must_copy = 1;
1262 } else {
1263 goto error;
1264 }
1265 break;
1266 case 4:
1267 if (!(is_atom(tp[1]) && is_atom(tp[2]))) {
1268 goto error;
1269 }
1270 location = tp[4];
1271 break;
1272 default:
1273 goto error;
1274 }
1275 if (is_not_list(location) && is_not_nil(location)) {
1276 goto error;
1277 }
1278 }
1279 if (is_not_nil(l)) goto error;
1280
1281 /* Create stacktrace and store */
1282 if (erts_backtrace_depth < depth) {
1283 depth = erts_backtrace_depth;
1284 if (depth == 0) {
1285 /*
1286 * For consistency with stacktraces generated
1287 * automatically, always include one element.
1288 */
1289 depth = 1;
1290 }
1291 must_copy = 1;
1292 }
1293 if (must_copy) {
1294 cnt = depth;
1295 c_p->ftrace = NIL;
1296 } else {
1297 /* No need to copy the stacktrace */
1298 cnt = 0;
1299 c_p->ftrace = stacktrace;
1300 }
1301
1302 tp = &c_p->ftrace;
1303 sz = (offsetof(struct StackTrace, trace) + sizeof(Eterm) - 1)
1304 / sizeof(Eterm);
1305 hp = HAlloc(c_p, sz + (2+6)*(cnt + 1));
1306 hp_end = hp + sz + (2+6)*(cnt + 1);
1307 s = (struct StackTrace *) hp;
1308 s->header = make_neg_bignum_header(sz - 1);
1309 s->freason = reason;
1310 s->pc = NULL;
1311 s->current = NULL;
1312 s->depth = 0;
1313 hp += sz;
1314 if (must_copy) {
1315 int cnt;
1316
1317 /* Copy list up to depth */
1318 for (cnt = 0, l = stacktrace;
1319 cnt < depth;
1320 cnt++, l = CDR(list_val(l))) {
1321 Eterm t;
1322 Eterm *tpp;
1323 int arity;
1324
1325 ASSERT(*tp == NIL);
1326 t = CAR(list_val(l));
1327 tpp = tuple_val(t);
1328 arity = arityval(tpp[0]);
1329 if (arity == 2) {
1330 t = TUPLE3(hp, tpp[1], tpp[2], NIL);
1331 hp += 4;
1332 } else if (arity == 3 && is_atom(tpp[1])) {
1333 t = TUPLE4(hp, tpp[1], tpp[2], tpp[3], NIL);
1334 hp += 5;
1335 }
1336 *tp = CONS(hp, t, *tp);
1337 tp = &CDR(list_val(*tp));
1338 hp += 2;
1339 }
1340 }
1341 c_p->ftrace = CONS(hp, c_p->ftrace, make_big((Eterm *) s));
1342 hp += 2;
1343 ASSERT(hp <= hp_end);
1344 HRelease(c_p, hp_end, hp);
1345 BIF_ERROR(c_p, reason);
1346
1347 error:
1348 return am_badarg;
1349 }
1350
1351 static BIF_RETTYPE
erts_internal_await_exit_trap(BIF_ALIST_0)1352 erts_internal_await_exit_trap(BIF_ALIST_0)
1353 {
1354 /*
1355 * We have sent ourselves an exit signal which will
1356 * terminate ourselves. Handle all signals until
1357 * terminated in order to ensure that signal order
1358 * is preserved. Yield if necessary.
1359 */
1360 erts_aint32_t state;
1361 int reds = ERTS_BIF_REDS_LEFT(BIF_P);
1362 (void) erts_proc_sig_handle_incoming(BIF_P, &state, &reds,
1363 reds, !0);
1364 BUMP_REDS(BIF_P, reds);
1365 if (state & ERTS_PSFLG_EXITING)
1366 ERTS_BIF_EXITED(BIF_P);
1367
1368 ERTS_BIF_YIELD0(&await_exit_trap, BIF_P);
1369 }
1370
1371 /**********************************************************************/
1372 /* send an exit signal to another process */
1373
send_exit_signal_bif(Process * c_p,Eterm id,Eterm reason,int exit2)1374 static BIF_RETTYPE send_exit_signal_bif(Process *c_p, Eterm id, Eterm reason, int exit2)
1375 {
1376 BIF_RETTYPE ret_val;
1377
1378 /*
1379 * 'id' not a process id, nor a local port id is a 'badarg' error.
1380 */
1381
1382 if (is_internal_pid(id)) {
1383 /*
1384 * Preserve the very old and *very strange* behaviour
1385 * of erlang:exit/2...
1386 *
1387 * - terminate ourselves even though exit reason
1388 * is normal (unless we trap exit)
1389 * - terminate ourselves before exit/2 return
1390 */
1391 int exit2_suicide = (exit2
1392 && c_p->common.id == id
1393 && (reason == am_kill
1394 || !(c_p->flags & F_TRAP_EXIT)));
1395 erts_proc_sig_send_exit(c_p, c_p->common.id, id,
1396 reason, NIL, exit2_suicide);
1397 if (!exit2_suicide)
1398 ERTS_BIF_PREP_RET(ret_val, am_true);
1399 else {
1400 erts_proc_lock(c_p, ERTS_PROC_LOCK_MSGQ);
1401 erts_proc_sig_fetch(c_p);
1402 erts_proc_unlock(c_p, ERTS_PROC_LOCK_MSGQ);
1403 ERTS_BIF_PREP_TRAP0(ret_val, &await_exit_trap, c_p);
1404 }
1405 }
1406 else if (is_internal_port(id)) {
1407 Eterm ref, *refp;
1408 Uint32 invalid_flags;
1409 Port *prt;
1410 ErtsPortOpResult res = ERTS_PORT_OP_DONE;
1411 #ifdef DEBUG
1412 ref = NIL;
1413 #endif
1414
1415 if (erts_port_synchronous_ops) {
1416 refp = &ref;
1417 invalid_flags = ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP;
1418 }
1419 else {
1420 refp = NULL;
1421 invalid_flags = ERTS_PORT_SFLGS_INVALID_LOOKUP;
1422 }
1423
1424 prt = erts_port_lookup(id, invalid_flags);
1425 if (prt)
1426 res = erts_port_exit(c_p, 0, prt, c_p->common.id, reason, refp);
1427
1428 if (!refp || res != ERTS_PORT_OP_SCHEDULED)
1429 ERTS_BIF_PREP_RET(ret_val, am_true);
1430 else {
1431 ASSERT(is_internal_ordinary_ref(ref));
1432 ERTS_BIF_PREP_TRAP3(ret_val, await_port_send_result_trap,
1433 c_p, ref, am_true, am_true);
1434 }
1435 }
1436 else if (is_external_pid(id)) {
1437 DistEntry *dep = external_pid_dist_entry(id);
1438 if (dep == erts_this_dist_entry)
1439 ERTS_BIF_PREP_RET(ret_val, am_true); /* Old incarnation of this node... */
1440 else {
1441 int code;
1442 ErtsDSigSendContext ctx;
1443
1444 code = erts_dsig_prepare(&ctx, dep, c_p, ERTS_PROC_LOCK_MAIN,
1445 ERTS_DSP_NO_LOCK, 0, 0, 1);
1446
1447 switch (code) {
1448 case ERTS_DSIG_PREP_NOT_ALIVE:
1449 case ERTS_DSIG_PREP_NOT_CONNECTED:
1450 ERTS_BIF_PREP_RET(ret_val, am_true);
1451 break;
1452 case ERTS_DSIG_PREP_PENDING:
1453 case ERTS_DSIG_PREP_CONNECTED:
1454 code = erts_dsig_send_exit2(&ctx, c_p->common.id, id, reason);
1455 switch (code) {
1456 case ERTS_DSIG_SEND_YIELD:
1457 ERTS_BIF_PREP_YIELD_RETURN(ret_val, c_p, am_true);
1458 break;
1459 case ERTS_DSIG_SEND_CONTINUE:
1460 BUMP_ALL_REDS(c_p);
1461 erts_set_gc_state(c_p, 0);
1462 ERTS_BIF_PREP_TRAP1(ret_val, &dsend_continue_trap_export, c_p,
1463 erts_dsend_export_trap_context(c_p, &ctx));
1464 break;
1465 case ERTS_DSIG_SEND_OK:
1466 ERTS_BIF_PREP_RET(ret_val, am_true);
1467 break;
1468 case ERTS_DSIG_SEND_TOO_LRG:
1469 erts_set_gc_state(c_p, 1);
1470 ERTS_BIF_PREP_ERROR(ret_val, c_p, SYSTEM_LIMIT);
1471 break;
1472 default:
1473 ASSERT(! "Invalid dsig send exit2 result");
1474 ERTS_BIF_PREP_ERROR(ret_val, c_p, EXC_INTERNAL_ERROR);
1475 break;
1476 }
1477 break;
1478 default:
1479 ASSERT(! "Invalid dsig prepare result");
1480 ERTS_BIF_PREP_ERROR(ret_val, c_p, EXC_INTERNAL_ERROR);
1481 break;
1482 }
1483 }
1484 }
1485 else if (is_external_port(id)) {
1486 DistEntry *dep = external_port_dist_entry(id);
1487 if(dep == erts_this_dist_entry)
1488 ERTS_BIF_PREP_RET(ret_val, am_true); /* Old incarnation of this node... */
1489 else
1490 ERTS_BIF_PREP_ERROR(ret_val, c_p, BADARG);
1491 }
1492 else {
1493 /* Not an id of a process or a port... */
1494
1495 ERTS_BIF_PREP_ERROR(ret_val, c_p, BADARG);
1496 }
1497
1498 return ret_val;
1499 }
1500
exit_2(BIF_ALIST_2)1501 BIF_RETTYPE exit_2(BIF_ALIST_2)
1502 {
1503 return send_exit_signal_bif(BIF_P, BIF_ARG_1, BIF_ARG_2, !0);
1504 }
1505
exit_signal_2(BIF_ALIST_2)1506 BIF_RETTYPE exit_signal_2(BIF_ALIST_2)
1507 {
1508 return send_exit_signal_bif(BIF_P, BIF_ARG_1, BIF_ARG_2, 0);
1509 }
1510
1511
1512 /**********************************************************************/
1513 /* this sets some process info- trapping exits or the error handler */
1514
1515
1516 /* Handle flags common to both process_flag_2 and process_flag_3. */
process_flag_aux(Process * c_p,int * redsp,Eterm flag,Eterm val)1517 static Eterm process_flag_aux(Process *c_p, int *redsp, Eterm flag, Eterm val)
1518 {
1519 Eterm old_value = NIL; /* shut up warning about use before set */
1520 Sint i;
1521
1522 if (redsp)
1523 *redsp = 1;
1524
1525 if (flag == am_save_calls) {
1526 struct saved_calls *scb;
1527 if (!is_small(val))
1528 goto error;
1529 i = signed_val(val);
1530 if (i < 0 || i > 10000)
1531 goto error;
1532
1533 if (i == 0)
1534 scb = NULL;
1535 else {
1536 Uint sz = sizeof(*scb) + (i-1) * sizeof(scb->ct[0]);
1537 scb = erts_alloc(ERTS_ALC_T_CALLS_BUF, sz);
1538 scb->len = i;
1539 scb->cur = 0;
1540 scb->n = 0;
1541 }
1542
1543 #ifdef HIPE
1544 if (c_p->flags & F_HIPE_MODE) {
1545 ASSERT(!ERTS_PROC_GET_SAVED_CALLS_BUF(c_p));
1546 scb = ERTS_PROC_SET_SUSPENDED_SAVED_CALLS_BUF(c_p, scb);
1547 }
1548 else
1549 #endif
1550 {
1551 #ifdef HIPE
1552 ASSERT(!ERTS_PROC_GET_SUSPENDED_SAVED_CALLS_BUF(c_p));
1553 #endif
1554 scb = ERTS_PROC_SET_SAVED_CALLS_BUF(c_p, scb);
1555
1556 if (((scb && i == 0) || (!scb && i != 0))) {
1557
1558 /*
1559 * Make sure we reschedule immediately so the
1560 * change take effect at once.
1561 */
1562 if (!redsp) {
1563 /* Executed via BIF call.. */
1564 via_bif:
1565
1566 /* Adjust fcalls to match save calls setting... */
1567 if (i == 0)
1568 c_p->fcalls += CONTEXT_REDS; /* disabled it */
1569 else
1570 c_p->fcalls -= CONTEXT_REDS; /* enabled it */
1571
1572 ERTS_VBUMP_ALL_REDS(c_p);
1573 }
1574 else {
1575 erts_aint32_t state;
1576 /*
1577 * Executed via signal handler. Try to figure
1578 * out in what context we are executing...
1579 */
1580
1581 state = erts_atomic32_read_nob(&c_p->state);
1582 if (state & (ERTS_PSFLG_RUNNING_SYS
1583 | ERTS_PSFLG_DIRTY_RUNNING_SYS
1584 | ERTS_PSFLG_DIRTY_RUNNING)) {
1585 /*
1586 * We are either processing signals before
1587 * being executed or executing dirty. That
1588 * is, no need to adjust anything...
1589 */
1590 *redsp = 1;
1591 }
1592 else {
1593 ErtsSchedulerData *esdp;
1594 ASSERT(state & ERTS_PSFLG_RUNNING);
1595
1596 /*
1597 * F_DELAY_GC is currently only set when
1598 * we handle signals in state running via
1599 * receive helper...
1600 */
1601
1602 if (!(c_p->flags & F_DELAY_GC)) {
1603 *redsp = 1;
1604 goto via_bif;
1605 }
1606
1607 /*
1608 * Executing via receive helper...
1609 *
1610 * We utilize the virtual reds counter
1611 * in order to get correct calculation
1612 * of reductions consumed when scheduling
1613 * out the process...
1614 */
1615
1616 esdp = erts_get_scheduler_data();
1617
1618 if (i == 0)
1619 esdp->virtual_reds += CONTEXT_REDS; /* disabled it */
1620 else
1621 esdp->virtual_reds -= CONTEXT_REDS; /* enabled it */
1622
1623 *redsp = -1;
1624 }
1625 }
1626 }
1627 }
1628
1629 if (!scb)
1630 old_value = make_small(0);
1631 else {
1632 old_value = make_small(scb->len);
1633 erts_free(ERTS_ALC_T_CALLS_BUF, (void *) scb);
1634 }
1635
1636 ASSERT(is_immed(old_value));
1637 return old_value;
1638 }
1639
1640 error:
1641 return am_badarg;
1642 }
1643
process_flag_2(BIF_ALIST_2)1644 BIF_RETTYPE process_flag_2(BIF_ALIST_2)
1645 {
1646 Eterm old_value;
1647 if (BIF_ARG_1 == am_error_handler) {
1648 if (is_not_atom(BIF_ARG_2)) {
1649 goto error;
1650 }
1651 old_value = erts_proc_set_error_handler(BIF_P, BIF_ARG_2);
1652 BIF_RET(old_value);
1653 }
1654 else if (BIF_ARG_1 == am_priority) {
1655 old_value = erts_set_process_priority(BIF_P, BIF_ARG_2);
1656 if (old_value == THE_NON_VALUE)
1657 goto error;
1658 BIF_RET(old_value);
1659 }
1660 else if (BIF_ARG_1 == am_trap_exit) {
1661 old_value = (BIF_P->flags & F_TRAP_EXIT) ? am_true : am_false;
1662 if (BIF_ARG_2 == am_true)
1663 BIF_P->flags |= F_TRAP_EXIT;
1664 else if (BIF_ARG_2 == am_false)
1665 BIF_P->flags &= ~F_TRAP_EXIT;
1666 else
1667 goto error;
1668 BIF_RET(old_value);
1669 }
1670 else if (BIF_ARG_1 == am_scheduler) {
1671 ErtsRunQueue *old, *new, *curr;
1672 Sint sched;
1673
1674 if (!is_small(BIF_ARG_2))
1675 goto error;
1676 sched = signed_val(BIF_ARG_2);
1677 if (sched < 0 || erts_no_schedulers < sched)
1678 goto error;
1679
1680 if (sched == 0) {
1681 old = erts_bind_runq_proc(BIF_P, 0);
1682 new = NULL;
1683 }
1684 else {
1685 int bound = !0;
1686 new = erts_schedid2runq(sched);
1687 old = erts_set_runq_proc(BIF_P, new, &bound);
1688 if (!bound)
1689 old = NULL;
1690 }
1691
1692 old_value = old ? make_small(old->ix+1) : make_small(0);
1693
1694 curr = erts_proc_sched_data(BIF_P)->run_queue;
1695
1696 ASSERT(!old || old == curr);
1697
1698 if (new && new != curr)
1699 ERTS_BIF_YIELD_RETURN_X(BIF_P, old_value, am_scheduler);
1700 else
1701 BIF_RET(old_value);
1702 }
1703 else if (BIF_ARG_1 == am_min_heap_size) {
1704 Sint i;
1705 if (!is_small(BIF_ARG_2)) {
1706 goto error;
1707 }
1708 i = signed_val(BIF_ARG_2);
1709 if (i < 0) {
1710 goto error;
1711 }
1712 old_value = make_small(BIF_P->min_heap_size);
1713 if (i < H_MIN_SIZE) {
1714 BIF_P->min_heap_size = H_MIN_SIZE;
1715 } else {
1716 BIF_P->min_heap_size = erts_next_heap_size(i, 0);
1717 }
1718 BIF_RET(old_value);
1719 }
1720 else if (BIF_ARG_1 == am_min_bin_vheap_size) {
1721 Sint i;
1722 if (!is_small(BIF_ARG_2)) {
1723 goto error;
1724 }
1725 i = signed_val(BIF_ARG_2);
1726 if (i < 0) {
1727 goto error;
1728 }
1729 old_value = make_small(BIF_P->min_vheap_size);
1730 if (i < BIN_VH_MIN_SIZE) {
1731 BIF_P->min_vheap_size = BIN_VH_MIN_SIZE;
1732 } else {
1733 BIF_P->min_vheap_size = erts_next_heap_size(i, 0);
1734 }
1735 BIF_RET(old_value);
1736 }
1737 else if (BIF_ARG_1 == am_max_heap_size) {
1738 Eterm *hp;
1739 Uint sz = 0, max_heap_size, max_heap_flags;
1740
1741 if (!erts_max_heap_size(BIF_ARG_2, &max_heap_size, &max_heap_flags))
1742 goto error;
1743
1744 if ((max_heap_size < MIN_HEAP_SIZE(BIF_P) && max_heap_size != 0))
1745 goto error;
1746
1747 erts_max_heap_size_map(MAX_HEAP_SIZE_GET(BIF_P), MAX_HEAP_SIZE_FLAGS_GET(BIF_P), NULL, &sz);
1748 hp = HAlloc(BIF_P, sz);
1749 old_value = erts_max_heap_size_map(MAX_HEAP_SIZE_GET(BIF_P), MAX_HEAP_SIZE_FLAGS_GET(BIF_P), &hp, NULL);
1750 MAX_HEAP_SIZE_SET(BIF_P, max_heap_size);
1751 MAX_HEAP_SIZE_FLAGS_SET(BIF_P, max_heap_flags);
1752 BIF_RET(old_value);
1753 }
1754 else if (BIF_ARG_1 == am_message_queue_data) {
1755 old_value = erts_change_message_queue_management(BIF_P, BIF_ARG_2);
1756 if (is_non_value(old_value))
1757 goto error;
1758 BIF_RET(old_value);
1759 }
1760 else if (BIF_ARG_1 == am_sensitive) {
1761 Uint is_sensitive;
1762 if (BIF_ARG_2 == am_true) {
1763 is_sensitive = 1;
1764 } else if (BIF_ARG_2 == am_false) {
1765 is_sensitive = 0;
1766 } else {
1767 goto error;
1768 }
1769 erts_proc_lock(BIF_P, ERTS_PROC_LOCKS_ALL_MINOR);
1770 old_value = (ERTS_TRACE_FLAGS(BIF_P) & F_SENSITIVE
1771 ? am_true
1772 : am_false);
1773 if (is_sensitive) {
1774 ERTS_TRACE_FLAGS(BIF_P) |= F_SENSITIVE;
1775 } else {
1776 ERTS_TRACE_FLAGS(BIF_P) &= ~F_SENSITIVE;
1777 }
1778 erts_proc_unlock(BIF_P, ERTS_PROC_LOCKS_ALL_MINOR);
1779 /* make sure to bump all reds so that we get
1780 rescheduled immediately so setting takes effect */
1781 BIF_RET2(old_value, CONTEXT_REDS);
1782 }
1783 else if (BIF_ARG_1 == am_monitor_nodes) {
1784 /*
1785 * This argument is intentionally *not* documented. It is intended
1786 * to be used by net_kernel:monitor_nodes/1.
1787 */
1788 old_value = erts_monitor_nodes(BIF_P, BIF_ARG_2, NIL);
1789 if (old_value == THE_NON_VALUE)
1790 goto error;
1791 BIF_RET(old_value);
1792 }
1793 else if (is_tuple(BIF_ARG_1)) {
1794 /*
1795 * This argument is intentionally *not* documented. It is intended
1796 * to be used by net_kernel:monitor_nodes/2.
1797 */
1798 Eterm *tp = tuple_val(BIF_ARG_1);
1799 if (arityval(tp[0]) == 2) {
1800 if (tp[1] == am_monitor_nodes) {
1801 old_value = erts_monitor_nodes(BIF_P, BIF_ARG_2, tp[2]);
1802 if (old_value == THE_NON_VALUE)
1803 goto error;
1804 BIF_RET(old_value);
1805 }
1806 }
1807 /* Fall through and try process_flag_aux() ... */
1808 }
1809
1810 old_value = process_flag_aux(BIF_P, NULL, BIF_ARG_1, BIF_ARG_2);
1811 if (old_value != am_badarg)
1812 BIF_RET(old_value);
1813 error:
1814 BIF_ERROR(BIF_P, BADARG);
1815 }
1816
1817 typedef struct {
1818 Eterm flag;
1819 Eterm value;
1820 ErlOffHeap oh;
1821 Eterm heap[1];
1822 } ErtsProcessFlag3Args;
1823
1824 static Eterm
exec_process_flag_3(Process * c_p,void * arg,int * redsp,ErlHeapFragment ** bpp)1825 exec_process_flag_3(Process *c_p, void *arg, int *redsp, ErlHeapFragment **bpp)
1826 {
1827 ErtsProcessFlag3Args *pf3a = arg;
1828 Eterm res;
1829
1830 if (ERTS_PROC_IS_EXITING(c_p))
1831 res = am_badarg;
1832 else
1833 res = process_flag_aux(c_p, redsp, pf3a->flag, pf3a->value);
1834 erts_cleanup_offheap(&pf3a->oh);
1835 erts_free(ERTS_ALC_T_PF3_ARGS, arg);
1836 return res;
1837 }
1838
1839
erts_internal_process_flag_3(BIF_ALIST_3)1840 BIF_RETTYPE erts_internal_process_flag_3(BIF_ALIST_3)
1841 {
1842 Eterm res, *hp;
1843 ErlOffHeap *ohp;
1844 ErtsProcessFlag3Args *pf3a;
1845 Uint flag_sz, value_sz;
1846
1847 if (BIF_P->common.id == BIF_ARG_1) {
1848 res = process_flag_aux(BIF_P, NULL, BIF_ARG_2, BIF_ARG_3);
1849 BIF_RET(res);
1850 }
1851
1852 if (is_not_internal_pid(BIF_ARG_1))
1853 BIF_RET(am_badarg);
1854
1855 flag_sz = is_immed(BIF_ARG_2) ? 0 : size_object(BIF_ARG_2);
1856 value_sz = is_immed(BIF_ARG_3) ? 0 : size_object(BIF_ARG_3);
1857
1858 pf3a = erts_alloc(ERTS_ALC_T_PF3_ARGS,
1859 sizeof(ErtsProcessFlag3Args)
1860 + sizeof(Eterm)*(flag_sz+value_sz-1));
1861
1862 ohp = &pf3a->oh;
1863 ERTS_INIT_OFF_HEAP(&pf3a->oh);
1864
1865 hp = &pf3a->heap[0];
1866
1867 pf3a->flag = copy_struct(BIF_ARG_2, flag_sz, &hp, ohp);
1868 pf3a->value = copy_struct(BIF_ARG_3, value_sz, &hp, ohp);
1869
1870 res = erts_proc_sig_send_rpc_request(BIF_P, BIF_ARG_1,
1871 !0,
1872 exec_process_flag_3,
1873 (void *) pf3a);
1874
1875 if (is_non_value(res)) {
1876 erts_free(ERTS_ALC_T_PF3_ARGS, pf3a);
1877 BIF_RET(am_badarg);
1878 }
1879
1880 return res;
1881 }
1882
1883 /**********************************************************************/
1884
1885 /* register(atom, Process|Port) registers a global process or port
1886 (for this node) */
1887
register_2(BIF_ALIST_2)1888 BIF_RETTYPE register_2(BIF_ALIST_2) /* (Atom, Pid|Port) */
1889 {
1890 if (erts_register_name(BIF_P, BIF_ARG_1, BIF_ARG_2))
1891 BIF_RET(am_true);
1892 else {
1893 BIF_ERROR(BIF_P, BADARG);
1894 }
1895 }
1896
1897
1898 /**********************************************************************/
1899
1900 /* removes the registration of a process or port */
1901
unregister_1(BIF_ALIST_1)1902 BIF_RETTYPE unregister_1(BIF_ALIST_1)
1903 {
1904 int res;
1905 if (is_not_atom(BIF_ARG_1)) {
1906 BIF_ERROR(BIF_P, BADARG);
1907 }
1908 res = erts_unregister_name(BIF_P, ERTS_PROC_LOCK_MAIN, NULL, BIF_ARG_1);
1909 if (res == 0) {
1910 BIF_ERROR(BIF_P, BADARG);
1911 }
1912 BIF_RET(am_true);
1913 }
1914
1915 /**********************************************************************/
1916
1917 /* find out the pid of a registered process */
1918 /* this is a rather unsafe BIF as it allows users to do nasty things. */
1919
whereis_1(BIF_ALIST_1)1920 BIF_RETTYPE whereis_1(BIF_ALIST_1)
1921 {
1922 Eterm res;
1923
1924 if (is_not_atom(BIF_ARG_1)) {
1925 BIF_ERROR(BIF_P, BADARG);
1926 }
1927 res = erts_whereis_name_to_id(BIF_P, BIF_ARG_1);
1928 BIF_RET(res);
1929 }
1930
1931 /**********************************************************************/
1932
1933 /*
1934 * erlang:'!'/2
1935 */
1936
1937 HIPE_WRAPPER_BIF_DISABLE_GC(ebif_bang, 2)
1938
1939 BIF_RETTYPE
ebif_bang_2(BIF_ALIST_2)1940 ebif_bang_2(BIF_ALIST_2)
1941 {
1942 return erl_send(BIF_P, BIF_ARG_1, BIF_ARG_2);
1943 }
1944
1945
1946 /*
1947 * Send a message to Process, Port or Registered Process.
1948 * Returns non-negative reduction bump or negative result code.
1949 */
1950 #define SEND_NOCONNECT (-1)
1951 #define SEND_YIELD (-2)
1952 #define SEND_YIELD_RETURN (-3)
1953 #define SEND_BADARG (-4)
1954 #define SEND_USER_ERROR (-5)
1955 #define SEND_INTERNAL_ERROR (-6)
1956 #define SEND_AWAIT_RESULT (-7)
1957 #define SEND_YIELD_CONTINUE (-8)
1958 #define SEND_SYSTEM_LIMIT (-9)
1959
1960
remote_send(Process * p,DistEntry * dep,Eterm to,Eterm node,Eterm full_to,Eterm msg,Eterm return_term,Eterm * ctxpp,int connect,int suspend)1961 static Sint remote_send(Process *p, DistEntry *dep,
1962 Eterm to, Eterm node, Eterm full_to, Eterm msg,
1963 Eterm return_term, Eterm *ctxpp,
1964 int connect, int suspend)
1965 {
1966 Sint res;
1967 int code;
1968 ErtsDSigSendContext ctx;
1969 ASSERT(is_atom(to) || is_external_pid(to));
1970
1971 code = erts_dsig_prepare(&ctx, dep, p, ERTS_PROC_LOCK_MAIN,
1972 ERTS_DSP_NO_LOCK,
1973 !suspend, 0, connect);
1974 ctx.return_term = return_term;
1975 ctx.node = node;
1976 switch (code) {
1977 case ERTS_DSIG_PREP_NOT_ALIVE:
1978 case ERTS_DSIG_PREP_NOT_CONNECTED:
1979 res = SEND_NOCONNECT;
1980 break;
1981 case ERTS_DSIG_PREP_WOULD_SUSPEND:
1982 ASSERT(!suspend);
1983 res = SEND_YIELD;
1984 break;
1985 case ERTS_DSIG_PREP_PENDING:
1986 case ERTS_DSIG_PREP_CONNECTED: {
1987
1988 if (is_atom(to))
1989 code = erts_dsig_send_reg_msg(&ctx, to, full_to, msg);
1990 else
1991 code = erts_dsig_send_msg(&ctx, to, msg);
1992 /*
1993 * Note that reductions have been bumped on calling
1994 * process by erts_dsig_send_reg_msg() or
1995 * erts_dsig_send_msg().
1996 */
1997 if (code == ERTS_DSIG_SEND_YIELD)
1998 res = SEND_YIELD_RETURN;
1999 else if (code == ERTS_DSIG_SEND_CONTINUE) {
2000 erts_set_gc_state(p, 0);
2001
2002 /* Keep a reference to the dist entry if the
2003 name is an not a pid. */
2004 if (is_atom(to)) {
2005 erts_ref_dist_entry(ctx.dep);
2006 ctx.deref_dep = 1;
2007 }
2008
2009 *ctxpp = erts_dsend_export_trap_context(p, &ctx);
2010 res = SEND_YIELD_CONTINUE;
2011 } else if (code == ERTS_DSIG_SEND_TOO_LRG)
2012 res = SEND_SYSTEM_LIMIT;
2013 else
2014 res = 0;
2015 break;
2016 }
2017 default:
2018 ASSERT(! "Invalid dsig prepare result");
2019 res = SEND_INTERNAL_ERROR;
2020 }
2021
2022 if (res >= 0) {
2023 if (IS_TRACED_FL(p, F_TRACE_SEND))
2024 trace_send(p, full_to, msg);
2025 if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
2026 save_calls(p, &exp_send);
2027 }
2028
2029 return res;
2030 }
2031
2032 static Sint
do_send(Process * p,Eterm to,Eterm msg,Eterm return_term,Eterm * refp,Eterm * dist_ctx,int connect,int suspend)2033 do_send(Process *p, Eterm to, Eterm msg, Eterm return_term, Eterm *refp,
2034 Eterm *dist_ctx, int connect, int suspend)
2035 {
2036 Eterm portid;
2037 Port *pt;
2038 Process* rp;
2039 DistEntry *dep;
2040 Eterm* tp;
2041
2042 if (is_internal_pid(to)) {
2043 if (IS_TRACED_FL(p, F_TRACE_SEND))
2044 trace_send(p, to, msg);
2045 if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
2046 save_calls(p, &exp_send);
2047
2048 rp = erts_proc_lookup_raw(to);
2049 if (!rp)
2050 return 0;
2051 } else if (is_external_pid(to)) {
2052 dep = external_pid_dist_entry(to);
2053 if(dep == erts_this_dist_entry) {
2054 erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf();
2055 erts_dsprintf(dsbufp,
2056 "Discarding message %T from %T to %T in an old "
2057 "incarnation (%u) of this node (%u)\n",
2058 msg,
2059 p->common.id,
2060 to,
2061 external_pid_creation(to),
2062 erts_this_node->creation);
2063 erts_send_error_to_logger(p->group_leader, dsbufp);
2064 return 0;
2065 }
2066 return remote_send(p, dep, to, dep->sysname, to, msg, return_term,
2067 dist_ctx, connect, suspend);
2068 } else if (is_atom(to)) {
2069 Eterm id = erts_whereis_name_to_id(p, to);
2070
2071 rp = erts_proc_lookup_raw(id);
2072 if (rp) {
2073 if (IS_TRACED_FL(p, F_TRACE_SEND))
2074 trace_send(p, to, msg);
2075 if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
2076 save_calls(p, &exp_send);
2077 goto send_message;
2078 }
2079
2080 pt = erts_port_lookup(id,
2081 (erts_port_synchronous_ops
2082 ? ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP
2083 : ERTS_PORT_SFLGS_INVALID_LOOKUP));
2084 if (pt) {
2085 portid = id;
2086 goto port_common;
2087 }
2088
2089 if (IS_TRACED_FL(p, F_TRACE_SEND))
2090 trace_send(p, to, msg);
2091 if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
2092 save_calls(p, &exp_send);
2093
2094 return SEND_BADARG;
2095 } else if (is_external_port(to)
2096 && (external_port_dist_entry(to)
2097 == erts_this_dist_entry)) {
2098 erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf();
2099 erts_dsprintf(dsbufp,
2100 "Discarding message %T from %T to %T in an old "
2101 "incarnation (%u) of this node (%u)\n",
2102 msg,
2103 p->common.id,
2104 to,
2105 external_port_creation(to),
2106 erts_this_node->creation);
2107 erts_send_error_to_logger(p->group_leader, dsbufp);
2108 return 0;
2109 } else if (is_internal_port(to)) {
2110 int ret_val;
2111 portid = to;
2112
2113 pt = erts_port_lookup(portid,
2114 (erts_port_synchronous_ops
2115 ? ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP
2116 : ERTS_PORT_SFLGS_INVALID_LOOKUP));
2117
2118 port_common:
2119 ret_val = 0;
2120
2121 if (pt) {
2122 int ps_flags = suspend ? 0 : ERTS_PORT_SIG_FLG_NOSUSPEND;
2123 *refp = NIL;
2124
2125 if (IS_TRACED_FL(p, F_TRACE_SEND)) /* trace once only !! */
2126 trace_send(p, portid, msg);
2127
2128 if (have_seqtrace(SEQ_TRACE_TOKEN(p))) {
2129 seq_trace_update_serial(p);
2130 seq_trace_output(SEQ_TRACE_TOKEN(p), msg,
2131 SEQ_TRACE_SEND, portid, p);
2132 }
2133
2134 switch (erts_port_command(p, ps_flags, pt, msg, refp)) {
2135 case ERTS_PORT_OP_BUSY:
2136 /* Nothing has been sent */
2137 if (suspend)
2138 erts_suspend(p, ERTS_PROC_LOCK_MAIN, pt);
2139 return SEND_YIELD;
2140 case ERTS_PORT_OP_BUSY_SCHEDULED:
2141 /* Message was sent */
2142 if (suspend) {
2143 erts_suspend(p, ERTS_PROC_LOCK_MAIN, pt);
2144 ret_val = SEND_YIELD_RETURN;
2145 break;
2146 }
2147 /* Fall through */
2148 case ERTS_PORT_OP_SCHEDULED:
2149 if (is_not_nil(*refp)) {
2150 ASSERT(is_internal_ordinary_ref(*refp));
2151 ret_val = SEND_AWAIT_RESULT;
2152 }
2153 break;
2154 case ERTS_PORT_OP_DROPPED:
2155 case ERTS_PORT_OP_BADARG:
2156 case ERTS_PORT_OP_DONE:
2157 break;
2158 default:
2159 ERTS_INTERNAL_ERROR("Unexpected erts_port_command() result");
2160 break;
2161 }
2162 }
2163
2164 if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
2165 save_calls(p, &exp_send);
2166
2167 if (ERTS_PROC_IS_EXITING(p)) {
2168 KILL_CATCHES(p); /* Must exit */
2169 return SEND_USER_ERROR;
2170 }
2171 return ret_val;
2172 } else if (is_tuple(to)) { /* Remote send */
2173 int deref_dep = 0;
2174 int ret;
2175 tp = tuple_val(to);
2176 if (*tp != make_arityval(2))
2177 return SEND_BADARG;
2178 if (is_not_atom(tp[1]) || is_not_atom(tp[2]))
2179 return SEND_BADARG;
2180
2181 /* erts_find_dist_entry will return NULL if there is no dist_entry
2182 but remote_send() will handle that. */
2183
2184 dep = erts_find_dist_entry(tp[2]);
2185
2186 if (dep == erts_this_dist_entry) {
2187 Eterm id;
2188 if (IS_TRACED_FL(p, F_TRACE_SEND))
2189 trace_send(p, to, msg);
2190 if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
2191 save_calls(p, &exp_send);
2192
2193 id = erts_whereis_name_to_id(p, tp[1]);
2194
2195 rp = erts_proc_lookup_raw(id);
2196 if (rp)
2197 goto send_message;
2198 pt = erts_port_lookup(id,
2199 (erts_port_synchronous_ops
2200 ? ERTS_PORT_SFLGS_INVALID_DRIVER_LOOKUP
2201 : ERTS_PORT_SFLGS_INVALID_LOOKUP));
2202 if (pt) {
2203 portid = id;
2204 goto port_common;
2205 }
2206 return 0;
2207 }
2208 if (dep == NULL) {
2209 dep = erts_find_or_insert_dist_entry(tp[2]);
2210 ASSERT(dep != erts_this_dist_entry);
2211 deref_dep = 1;
2212 }
2213
2214 ret = remote_send(p, dep, tp[1], tp[2], to, msg, return_term,
2215 dist_ctx, connect, suspend);
2216
2217 if (deref_dep)
2218 erts_deref_dist_entry(dep);
2219 return ret;
2220 } else {
2221 if (IS_TRACED_FL(p, F_TRACE_SEND))
2222 trace_send(p, to, msg);
2223 if (ERTS_PROC_GET_SAVED_CALLS_BUF(p))
2224 save_calls(p, &exp_send);
2225 return SEND_BADARG;
2226 }
2227
2228 send_message: {
2229 ErtsProcLocks rp_locks = 0;
2230 if (p == rp)
2231 rp_locks |= ERTS_PROC_LOCK_MAIN;
2232 /* send to local process */
2233 erts_send_message(p, rp, &rp_locks, msg);
2234 erts_proc_unlock(rp,
2235 p == rp
2236 ? (rp_locks & ~ERTS_PROC_LOCK_MAIN)
2237 : rp_locks);
2238 return 0;
2239 }
2240 }
2241
2242 HIPE_WRAPPER_BIF_DISABLE_GC(send, 3)
2243
send_3(BIF_ALIST_3)2244 BIF_RETTYPE send_3(BIF_ALIST_3)
2245 {
2246 BIF_RETTYPE retval;
2247 Eterm ref;
2248 Process *p = BIF_P;
2249 Eterm to = BIF_ARG_1;
2250 Eterm msg = BIF_ARG_2;
2251 Eterm opts = BIF_ARG_3;
2252
2253 Eterm l = opts;
2254 Sint result;
2255 int connect = 1, suspend = 1;
2256 Eterm ctx;
2257
2258 ERTS_MSACC_PUSH_STATE_M_X();
2259
2260 while (is_list(l)) {
2261 if (CAR(list_val(l)) == am_noconnect) {
2262 connect = 0;
2263 } else if (CAR(list_val(l)) == am_nosuspend) {
2264 suspend = 0;
2265 } else {
2266 ERTS_BIF_PREP_ERROR(retval, p, BADARG);
2267 goto done;
2268 }
2269 l = CDR(list_val(l));
2270 }
2271 if(!is_nil(l)) {
2272 ERTS_BIF_PREP_ERROR(retval, p, BADARG);
2273 goto done;
2274 }
2275
2276 #ifdef DEBUG
2277 ref = NIL;
2278 #endif
2279
2280 ERTS_MSACC_SET_STATE_CACHED_M_X(ERTS_MSACC_STATE_SEND);
2281 result = do_send(p, to, msg, am_ok, &ref, &ctx, connect, suspend);
2282 ERTS_MSACC_POP_STATE_M_X();
2283
2284 if (result >= 0) {
2285 ERTS_VBUMP_REDS(p, 4);
2286 if (ERTS_IS_PROC_OUT_OF_REDS(p))
2287 goto yield_return;
2288 ERTS_BIF_PREP_RET(retval, am_ok);
2289 goto done;
2290 }
2291
2292 switch (result) {
2293 case SEND_NOCONNECT:
2294 if (connect) {
2295 ERTS_BIF_PREP_RET(retval, am_ok);
2296 } else {
2297 ERTS_BIF_PREP_RET(retval, am_noconnect);
2298 }
2299 break;
2300 case SEND_YIELD:
2301 if (suspend) {
2302 ERTS_BIF_PREP_YIELD3(retval, &bif_trap_export[BIF_send_3], p, to, msg, opts);
2303 } else {
2304 ERTS_BIF_PREP_RET(retval, am_nosuspend);
2305 }
2306 break;
2307 case SEND_YIELD_RETURN:
2308 if (!suspend) {
2309 ERTS_BIF_PREP_RET(retval, am_nosuspend);
2310 break;
2311 }
2312 yield_return:
2313 ERTS_BIF_PREP_YIELD_RETURN(retval, p, am_ok);
2314 break;
2315 case SEND_AWAIT_RESULT:
2316 ASSERT(is_internal_ordinary_ref(ref));
2317 ERTS_BIF_PREP_TRAP3(retval, await_port_send_result_trap, p, ref, am_nosuspend, am_ok);
2318 break;
2319 case SEND_BADARG:
2320 ERTS_BIF_PREP_ERROR(retval, p, BADARG);
2321 break;
2322 case SEND_SYSTEM_LIMIT:
2323 ERTS_BIF_PREP_ERROR(retval, p, SYSTEM_LIMIT);
2324 break;
2325 case SEND_USER_ERROR:
2326 ERTS_BIF_PREP_ERROR(retval, p, EXC_ERROR);
2327 break;
2328 case SEND_INTERNAL_ERROR:
2329 ERTS_BIF_PREP_ERROR(retval, p, EXC_INTERNAL_ERROR);
2330 break;
2331 case SEND_YIELD_CONTINUE:
2332 BUMP_ALL_REDS(p);
2333 ERTS_BIF_PREP_TRAP1(retval, &dsend_continue_trap_export, p, ctx);
2334 break;
2335 default:
2336 erts_exit(ERTS_ABORT_EXIT, "send_3 invalid result %d\n", (int)result);
2337 break;
2338 }
2339
2340 done:
2341 return retval;
2342 }
2343
2344 HIPE_WRAPPER_BIF_DISABLE_GC(send, 2)
2345
send_2(BIF_ALIST_2)2346 BIF_RETTYPE send_2(BIF_ALIST_2)
2347 {
2348 return erl_send(BIF_P, BIF_ARG_1, BIF_ARG_2);
2349 }
2350
dsend_continue_trap_1(BIF_ALIST_1)2351 static BIF_RETTYPE dsend_continue_trap_1(BIF_ALIST_1)
2352 {
2353 Binary* bin = erts_magic_ref2bin(BIF_ARG_1);
2354 ErtsDSigSendContext *ctx = (ErtsDSigSendContext*) ERTS_MAGIC_BIN_DATA(bin);
2355 Sint initial_reds = (Sint) (ERTS_BIF_REDS_LEFT(BIF_P) * TERM_TO_BINARY_LOOP_FACTOR);
2356 int result;
2357
2358 ASSERT(ERTS_MAGIC_BIN_DESTRUCTOR(bin) == erts_dsend_context_dtor);
2359
2360 ctx->reds = initial_reds;
2361 result = erts_dsig_send(ctx);
2362
2363 switch (result) {
2364 case ERTS_DSIG_SEND_OK:
2365 erts_set_gc_state(BIF_P, 1);
2366 BIF_RET(ctx->return_term);
2367 break;
2368 case ERTS_DSIG_SEND_YIELD: /*SEND_YIELD_RETURN*/
2369 erts_set_gc_state(BIF_P, 1);
2370 if (ctx->no_suspend)
2371 BIF_RET(am_nosuspend);
2372 ERTS_BIF_YIELD_RETURN(BIF_P, ctx->return_term);
2373
2374 case ERTS_DSIG_SEND_CONTINUE: { /*SEND_YIELD_CONTINUE*/
2375 BUMP_ALL_REDS(BIF_P);
2376 BIF_TRAP1(&dsend_continue_trap_export, BIF_P, BIF_ARG_1);
2377 }
2378 case ERTS_DSIG_SEND_TOO_LRG: { /*SEND_SYSTEM_LIMIT*/
2379 erts_set_gc_state(BIF_P, 1);
2380 BIF_ERROR(BIF_P, SYSTEM_LIMIT);
2381 }
2382 default:
2383 erts_exit(ERTS_ABORT_EXIT, "dsend_continue_trap invalid result %d\n", (int)result);
2384 break;
2385 }
2386 ASSERT(! "Can not arrive here");
2387 BIF_ERROR(BIF_P, BADARG);
2388 }
2389
erl_send(Process * p,Eterm to,Eterm msg)2390 Eterm erl_send(Process *p, Eterm to, Eterm msg)
2391 {
2392 Eterm retval;
2393 Eterm ref;
2394 Sint result;
2395 Eterm ctx;
2396 ERTS_MSACC_PUSH_AND_SET_STATE_M_X(ERTS_MSACC_STATE_SEND);
2397
2398 #ifdef DEBUG
2399 ref = NIL;
2400 #endif
2401
2402 result = do_send(p, to, msg, msg, &ref, &ctx, 1, 1);
2403
2404 ERTS_MSACC_POP_STATE_M_X();
2405
2406 if (result >= 0) {
2407 ERTS_VBUMP_REDS(p, 4);
2408 if (ERTS_IS_PROC_OUT_OF_REDS(p))
2409 goto yield_return;
2410 ERTS_BIF_PREP_RET(retval, msg);
2411 goto done;
2412 }
2413
2414 switch (result) {
2415 case SEND_NOCONNECT:
2416 ERTS_BIF_PREP_RET(retval, msg);
2417 break;
2418 case SEND_YIELD:
2419 ERTS_BIF_PREP_YIELD2(retval, &bif_trap_export[BIF_send_2], p, to, msg);
2420 break;
2421 case SEND_YIELD_RETURN:
2422 yield_return:
2423 ERTS_BIF_PREP_YIELD_RETURN(retval, p, msg);
2424 break;
2425 case SEND_AWAIT_RESULT:
2426 ASSERT(is_internal_ordinary_ref(ref));
2427 ERTS_BIF_PREP_TRAP3(retval,
2428 await_port_send_result_trap, p, ref, msg, msg);
2429 break;
2430 case SEND_BADARG:
2431 ERTS_BIF_PREP_ERROR(retval, p, BADARG);
2432 break;
2433 case SEND_SYSTEM_LIMIT:
2434 ERTS_BIF_PREP_ERROR(retval, p, SYSTEM_LIMIT);
2435 break;
2436 case SEND_USER_ERROR:
2437 ERTS_BIF_PREP_ERROR(retval, p, EXC_ERROR);
2438 break;
2439 case SEND_INTERNAL_ERROR:
2440 ERTS_BIF_PREP_ERROR(retval, p, EXC_INTERNAL_ERROR);
2441 break;
2442 case SEND_YIELD_CONTINUE:
2443 BUMP_ALL_REDS(p);
2444 ERTS_BIF_PREP_TRAP1(retval, &dsend_continue_trap_export, p, ctx);
2445 break;
2446 default:
2447 erts_exit(ERTS_ABORT_EXIT, "invalid send result %d\n", (int)result);
2448 break;
2449 }
2450
2451 done:
2452 return retval;
2453 }
2454
2455 /**********************************************************************/
2456
2457 /* integer to float */
2458
2459 /**********************************************************************/
2460
2461 /* returns the head of a list - this function is unecessary
2462 and is only here to keep Robert happy (Even more, since it's OP as well) */
hd_1(BIF_ALIST_1)2463 BIF_RETTYPE hd_1(BIF_ALIST_1)
2464 {
2465 if (is_not_list(BIF_ARG_1)) {
2466 BIF_ERROR(BIF_P, BADARG);
2467 }
2468 BIF_RET(CAR(list_val(BIF_ARG_1)));
2469 }
2470
2471 /**********************************************************************/
2472
2473 /* returns the tails of a list - same comment as above */
2474
tl_1(BIF_ALIST_1)2475 BIF_RETTYPE tl_1(BIF_ALIST_1)
2476 {
2477 if (is_not_list(BIF_ARG_1)) {
2478 BIF_ERROR(BIF_P, BADARG);
2479 }
2480 BIF_RET(CDR(list_val(BIF_ARG_1)));
2481 }
2482
2483
2484 /**********************************************************************/
2485 /* return the size of an I/O list */
2486
2487 static Eterm
accumulate(Eterm acc,Uint size)2488 accumulate(Eterm acc, Uint size)
2489 {
2490 if (is_non_value(acc)) {
2491 /*
2492 * There is no pre-existing accumulator. Allocate a
2493 * bignum buffer with one extra word to be used if
2494 * the bignum grows in the future.
2495 */
2496 Eterm* hp = (Eterm *) erts_alloc(ERTS_ALC_T_SHORT_LIVED_TERM,
2497 (BIG_UINT_HEAP_SIZE+1) *
2498 sizeof(Eterm));
2499 return uint_to_big(size, hp);
2500 } else {
2501 Eterm* big;
2502 int need_heap;
2503
2504 /*
2505 * Add 'size' to 'acc' in place. There is always one
2506 * extra word allocated in case the bignum grows by one word.
2507 */
2508 big = big_val(acc);
2509 need_heap = BIG_NEED_SIZE(BIG_SIZE(big));
2510 acc = big_plus_small(acc, size, big);
2511 if (BIG_NEED_SIZE(big_size(acc)) > need_heap) {
2512 /*
2513 * The extra word has been consumed. Grow the
2514 * allocation by one word.
2515 */
2516 big = (Eterm *) erts_realloc(ERTS_ALC_T_SHORT_LIVED_TERM,
2517 big_val(acc),
2518 (need_heap+1) * sizeof(Eterm));
2519 acc = make_big(big);
2520 }
2521 return acc;
2522 }
2523 }
2524
2525 static Eterm
consolidate(Process * p,Eterm acc,Uint size)2526 consolidate(Process* p, Eterm acc, Uint size)
2527 {
2528 Eterm* hp;
2529
2530 if (is_non_value(acc)) {
2531 return erts_make_integer(size, p);
2532 } else {
2533 Eterm* big;
2534 Uint sz;
2535 Eterm res;
2536
2537 acc = accumulate(acc, size);
2538 big = big_val(acc);
2539 sz = BIG_NEED_SIZE(BIG_SIZE(big));
2540 hp = HAlloc(p, sz);
2541 res = make_big(hp);
2542 while (sz--) {
2543 *hp++ = *big++;
2544 }
2545 erts_free(ERTS_ALC_T_SHORT_LIVED_TERM, (void *) big_val(acc));
2546 return res;
2547 }
2548 }
2549
2550 typedef struct {
2551 Eterm obj;
2552 Uint size;
2553 Eterm acc;
2554 Eterm input_list;
2555 ErtsEStack stack;
2556 int is_trap_at_L_iter_list;
2557 } ErtsIOListSizeContext;
2558
iolist_size_ctx_bin_dtor(Binary * context_bin)2559 static int iolist_size_ctx_bin_dtor(Binary *context_bin) {
2560 ErtsIOListSizeContext* context = ERTS_MAGIC_BIN_DATA(context_bin);
2561 DESTROY_SAVED_ESTACK(&context->stack);
2562 if (context->acc != THE_NON_VALUE) {
2563 erts_free(ERTS_ALC_T_SHORT_LIVED_TERM, (void *) big_val(context->acc));
2564 }
2565 return 1;
2566 }
2567
iolist_size_1(BIF_ALIST_1)2568 BIF_RETTYPE iolist_size_1(BIF_ALIST_1)
2569 {
2570 static const Uint ITERATIONS_PER_RED = 64;
2571 Eterm input_list, obj, hd;
2572 Eterm* objp;
2573 Uint size = 0;
2574 Uint cur_size;
2575 Uint new_size;
2576 Eterm acc = THE_NON_VALUE;
2577 DECLARE_ESTACK(s);
2578 Uint max_iterations;
2579 Uint iterations_until_trap = max_iterations =
2580 ITERATIONS_PER_RED * ERTS_BIF_REDS_LEFT(BIF_P);
2581 ErtsIOListSizeContext* context = NULL;
2582 Eterm state_mref;
2583 int is_trap_at_L_iter_list;
2584 ERTS_UNDEF(state_mref, THE_NON_VALUE);
2585 ESTACK_CHANGE_ALLOCATOR(s, ERTS_ALC_T_SAVED_ESTACK);
2586 #ifdef DEBUG
2587 iterations_until_trap = iterations_until_trap / 10;
2588 #endif
2589 input_list = obj = BIF_ARG_1;
2590 if (is_internal_magic_ref(obj)) {
2591 /* Restore state after a trap */
2592 Binary* state_bin;
2593 state_mref = obj;
2594 state_bin = erts_magic_ref2bin(state_mref);
2595 if (ERTS_MAGIC_BIN_DESTRUCTOR(state_bin) != iolist_size_ctx_bin_dtor) {
2596 BIF_ERROR(BIF_P, BADARG);
2597 }
2598 context = ERTS_MAGIC_BIN_DATA(state_bin);
2599 obj = context->obj;
2600 size = context->size;
2601 acc = context->acc;
2602 input_list = context->input_list;
2603 ESTACK_RESTORE(s, &context->stack);
2604 ASSERT(BIF_P->flags & F_DISABLE_GC);
2605 erts_set_gc_state(BIF_P, 1);
2606 if (context->is_trap_at_L_iter_list) {
2607 goto L_iter_list;
2608 }
2609 }
2610 goto L_again;
2611
2612 while (!ESTACK_ISEMPTY(s)) {
2613 obj = ESTACK_POP(s);
2614 if (iterations_until_trap == 0) {
2615 is_trap_at_L_iter_list = 0;
2616 goto L_save_state_and_trap;
2617 }
2618 L_again:
2619 if (is_list(obj)) {
2620 L_iter_list:
2621 if (iterations_until_trap == 0) {
2622 is_trap_at_L_iter_list = 1;
2623 goto L_save_state_and_trap;
2624 }
2625 objp = list_val(obj);
2626 hd = CAR(objp);
2627 obj = CDR(objp);
2628 /* Head */
2629 if (is_byte(hd)) {
2630 size++;
2631 if (size == 0) {
2632 acc = accumulate(acc, (Uint) -1);
2633 size = 1;
2634 }
2635 } else if (is_binary(hd) && binary_bitsize(hd) == 0) {
2636 cur_size = binary_size(hd);
2637 if ((new_size = size + cur_size) >= size) {
2638 size = new_size;
2639 } else {
2640 acc = accumulate(acc, size);
2641 size = cur_size;
2642 }
2643 } else if (is_list(hd)) {
2644 ESTACK_PUSH(s, obj);
2645 obj = hd;
2646 iterations_until_trap--;
2647 goto L_iter_list;
2648 } else if (is_not_nil(hd)) {
2649 goto L_type_error;
2650 }
2651 /* Tail */
2652 if (is_list(obj)) {
2653 iterations_until_trap--;
2654 goto L_iter_list;
2655 } else if (is_binary(obj) && binary_bitsize(obj) == 0) {
2656 cur_size = binary_size(obj);
2657 if ((new_size = size + cur_size) >= size) {
2658 size = new_size;
2659 } else {
2660 acc = accumulate(acc, size);
2661 size = cur_size;
2662 }
2663 } else if (is_not_nil(obj)) {
2664 goto L_type_error;
2665 }
2666 } else if (is_binary(obj) && binary_bitsize(obj) == 0) {
2667 cur_size = binary_size(obj);
2668 if ((new_size = size + cur_size) >= size) {
2669 size = new_size;
2670 } else {
2671 acc = accumulate(acc, size);
2672 size = cur_size;
2673 }
2674 } else if (is_not_nil(obj)) {
2675 goto L_type_error;
2676 }
2677 iterations_until_trap--;
2678 }
2679
2680 DESTROY_ESTACK(s);
2681 BUMP_REDS(BIF_P, (max_iterations - iterations_until_trap) / ITERATIONS_PER_RED);
2682 ASSERT(!(BIF_P->flags & F_DISABLE_GC));
2683 if (context != NULL) {
2684 /* context->acc needs to be reset so that
2685 iolist_size_ctx_bin_dtor does not deallocate twice */
2686 context->acc = THE_NON_VALUE;
2687 }
2688 BIF_RET(consolidate(BIF_P, acc, size));
2689
2690 L_type_error:
2691 DESTROY_ESTACK(s);
2692 if (acc != THE_NON_VALUE) {
2693 erts_free(ERTS_ALC_T_SHORT_LIVED_TERM, (void *) big_val(acc));
2694 if (context != NULL) {
2695 context->acc = THE_NON_VALUE;
2696 }
2697 }
2698 BUMP_REDS(BIF_P, (max_iterations - iterations_until_trap) / ITERATIONS_PER_RED);
2699 ASSERT(!(BIF_P->flags & F_DISABLE_GC));
2700 if (context == NULL) {
2701 BIF_ERROR(BIF_P, BADARG);
2702 } else {
2703 ERTS_BIF_ERROR_TRAPPED1(BIF_P,
2704 BADARG,
2705 &bif_trap_export[BIF_iolist_size_1],
2706 input_list);
2707 }
2708
2709 L_save_state_and_trap:
2710 if (context == NULL) {
2711 Binary *state_bin = erts_create_magic_binary(sizeof(ErtsIOListSizeContext),
2712 iolist_size_ctx_bin_dtor);
2713 Eterm* hp = HAlloc(BIF_P, ERTS_MAGIC_REF_THING_SIZE);
2714 state_mref = erts_mk_magic_ref(&hp, &MSO(BIF_P), state_bin);
2715 context = ERTS_MAGIC_BIN_DATA(state_bin);
2716 }
2717 context->obj = obj;
2718 context->size = size;
2719 context->acc = acc;
2720 context->is_trap_at_L_iter_list = is_trap_at_L_iter_list;
2721 context->input_list = input_list;
2722 ESTACK_SAVE(s, &context->stack);
2723 erts_set_gc_state(BIF_P, 0);
2724 BUMP_ALL_REDS(BIF_P);
2725 BIF_TRAP1(&bif_trap_export[BIF_iolist_size_1], BIF_P, state_mref);
2726 }
2727
2728 /**********************************************************************/
2729
2730 /* return the N'th element of a tuple */
2731
element_2(BIF_ALIST_2)2732 BIF_RETTYPE element_2(BIF_ALIST_2)
2733 {
2734 if (is_not_small(BIF_ARG_1)) {
2735 BIF_ERROR(BIF_P, BADARG);
2736 }
2737 if (is_tuple(BIF_ARG_2)) {
2738 Eterm* tuple_ptr = tuple_val(BIF_ARG_2);
2739 Sint ix = signed_val(BIF_ARG_1);
2740
2741 if ((ix >= 1) && (ix <= arityval(*tuple_ptr)))
2742 BIF_RET(tuple_ptr[ix]);
2743 }
2744 BIF_ERROR(BIF_P, BADARG);
2745 }
2746
2747 /**********************************************************************/
2748
2749 /* return the arity of a tuple */
2750
tuple_size_1(BIF_ALIST_1)2751 BIF_RETTYPE tuple_size_1(BIF_ALIST_1)
2752 {
2753 if (is_tuple(BIF_ARG_1)) {
2754 return make_small(arityval(*tuple_val(BIF_ARG_1)));
2755 }
2756 BIF_ERROR(BIF_P, BADARG);
2757 }
2758
2759 /**********************************************************************/
2760
2761 /* set the n'th element in a tuple */
2762
setelement_3(BIF_ALIST_3)2763 BIF_RETTYPE setelement_3(BIF_ALIST_3)
2764 {
2765 Eterm* ptr;
2766 Eterm* hp;
2767 Eterm* resp;
2768 Uint ix;
2769 Uint size;
2770
2771 if (is_not_small(BIF_ARG_1) || is_not_tuple(BIF_ARG_2)) {
2772 error:
2773 BIF_ERROR(BIF_P, BADARG);
2774 }
2775 ptr = tuple_val(BIF_ARG_2);
2776 ix = signed_val(BIF_ARG_1);
2777 size = arityval(*ptr) + 1; /* include arity */
2778 if ((ix < 1) || (ix >= size)) {
2779 goto error;
2780 }
2781
2782 hp = HAlloc(BIF_P, size);
2783
2784 /* copy the tuple */
2785 resp = hp;
2786 sys_memcpy(hp, ptr, sizeof(Eterm)*size);
2787 resp[ix] = BIF_ARG_3;
2788 BIF_RET(make_tuple(resp));
2789 }
2790
2791 /**********************************************************************/
2792
make_tuple_2(BIF_ALIST_2)2793 BIF_RETTYPE make_tuple_2(BIF_ALIST_2)
2794 {
2795 Sint n;
2796 Eterm* hp;
2797 Eterm res;
2798
2799 if (is_not_small(BIF_ARG_1) || (n = signed_val(BIF_ARG_1)) < 0 || n > ERTS_MAX_TUPLE_SIZE) {
2800 BIF_ERROR(BIF_P, BADARG);
2801 }
2802 hp = HAlloc(BIF_P, n+1);
2803 res = make_tuple(hp);
2804 *hp++ = make_arityval(n);
2805 while (n--) {
2806 *hp++ = BIF_ARG_2;
2807 }
2808 BIF_RET(res);
2809 }
2810
make_tuple_3(BIF_ALIST_3)2811 BIF_RETTYPE make_tuple_3(BIF_ALIST_3)
2812 {
2813 Sint n;
2814 Uint limit;
2815 Eterm* hp;
2816 Eterm res;
2817 Eterm list = BIF_ARG_3;
2818 Eterm* tup;
2819
2820 if (is_not_small(BIF_ARG_1) || (n = signed_val(BIF_ARG_1)) < 0 || n > ERTS_MAX_TUPLE_SIZE) {
2821 error:
2822 BIF_ERROR(BIF_P, BADARG);
2823 }
2824 limit = (Uint) n;
2825 hp = HAlloc(BIF_P, n+1);
2826 res = make_tuple(hp);
2827 *hp++ = make_arityval(n);
2828 tup = hp;
2829 while (n--) {
2830 *hp++ = BIF_ARG_2;
2831 }
2832 while(is_list(list)) {
2833 Eterm* cons;
2834 Eterm hd;
2835 Eterm* tp;
2836 Eterm index;
2837 Uint index_val;
2838
2839 cons = list_val(list);
2840 hd = CAR(cons);
2841 list = CDR(cons);
2842 if (is_not_tuple_arity(hd, 2)) {
2843 goto error;
2844 }
2845 tp = tuple_val(hd);
2846 if (is_not_small(index = tp[1])) {
2847 goto error;
2848 }
2849 if ((index_val = unsigned_val(index) - 1) < limit) {
2850 tup[index_val] = tp[2];
2851 } else {
2852 goto error;
2853 }
2854 }
2855 if (is_not_nil(list)) {
2856 goto error;
2857 }
2858 BIF_RET(res);
2859 }
2860
2861
2862 /**********************************************************************/
2863
append_element_2(BIF_ALIST_2)2864 BIF_RETTYPE append_element_2(BIF_ALIST_2)
2865 {
2866 Eterm* ptr;
2867 Eterm* hp;
2868 Uint arity;
2869 Eterm res;
2870
2871 if (is_not_tuple(BIF_ARG_1)) {
2872 error:
2873 BIF_ERROR(BIF_P, BADARG);
2874 }
2875 ptr = tuple_val(BIF_ARG_1);
2876 arity = arityval(*ptr);
2877
2878 if (arity + 1 > ERTS_MAX_TUPLE_SIZE)
2879 goto error;
2880
2881 hp = HAlloc(BIF_P, arity + 2);
2882 res = make_tuple(hp);
2883 *hp = make_arityval(arity+1);
2884 while (arity--) {
2885 *++hp = *++ptr;
2886 }
2887 *++hp = BIF_ARG_2;
2888 BIF_RET(res);
2889 }
2890
insert_element_3(BIF_ALIST_3)2891 BIF_RETTYPE insert_element_3(BIF_ALIST_3)
2892 {
2893 Eterm* ptr;
2894 Eterm* hp;
2895 Uint arity;
2896 Eterm res;
2897 Sint ix, c1, c2;
2898
2899 if (is_not_tuple(BIF_ARG_2) || is_not_small(BIF_ARG_1)) {
2900 BIF_ERROR(BIF_P, BADARG);
2901 }
2902
2903 ptr = tuple_val(BIF_ARG_2);
2904 arity = arityval(*ptr);
2905 ix = signed_val(BIF_ARG_1);
2906
2907 if ((ix < 1) || (ix > (arity + 1))) {
2908 BIF_ERROR(BIF_P, BADARG);
2909 }
2910
2911 hp = HAlloc(BIF_P, arity + 1 + 1);
2912 res = make_tuple(hp);
2913 *hp = make_arityval(arity + 1);
2914
2915 c1 = ix - 1;
2916 c2 = arity - ix + 1;
2917
2918 while (c1--) { *++hp = *++ptr; }
2919 *++hp = BIF_ARG_3;
2920 while (c2--) { *++hp = *++ptr; }
2921
2922 BIF_RET(res);
2923 }
2924
delete_element_2(BIF_ALIST_3)2925 BIF_RETTYPE delete_element_2(BIF_ALIST_3)
2926 {
2927 Eterm* ptr;
2928 Eterm* hp;
2929 Uint arity;
2930 Eterm res;
2931 Sint ix, c1, c2;
2932
2933 if (is_not_tuple(BIF_ARG_2) || is_not_small(BIF_ARG_1)) {
2934 BIF_ERROR(BIF_P, BADARG);
2935 }
2936
2937 ptr = tuple_val(BIF_ARG_2);
2938 arity = arityval(*ptr);
2939 ix = signed_val(BIF_ARG_1);
2940
2941 if ((ix < 1) || (ix > arity) || (arity == 0)) {
2942 BIF_ERROR(BIF_P, BADARG);
2943 }
2944
2945 hp = HAlloc(BIF_P, arity + 1 - 1);
2946 res = make_tuple(hp);
2947 *hp = make_arityval(arity - 1);
2948
2949 c1 = ix - 1;
2950 c2 = arity - ix;
2951
2952 while (c1--) { *++hp = *++ptr; }
2953 ++ptr;
2954 while (c2--) { *++hp = *++ptr; }
2955
2956 BIF_RET(res);
2957 }
2958
2959 /**********************************************************************/
2960
2961 /* convert an atom to a list of ascii integer */
2962
atom_to_list_1(BIF_ALIST_1)2963 BIF_RETTYPE atom_to_list_1(BIF_ALIST_1)
2964 {
2965 Atom* ap;
2966 Uint num_chars, num_built, num_eaten;
2967 byte* err_pos;
2968 Eterm res;
2969 int ares;
2970
2971 if (is_not_atom(BIF_ARG_1))
2972 BIF_ERROR(BIF_P, BADARG);
2973
2974 /* read data from atom table */
2975 ap = atom_tab(atom_val(BIF_ARG_1));
2976 if (ap->len == 0)
2977 BIF_RET(NIL); /* the empty atom */
2978
2979 ares =
2980 erts_analyze_utf8(ap->name, ap->len, &err_pos, &num_chars, NULL);
2981 ASSERT(ares == ERTS_UTF8_OK); (void)ares;
2982
2983 res = erts_utf8_to_list(BIF_P, num_chars, ap->name, ap->len, ap->len,
2984 &num_built, &num_eaten, NIL);
2985 ASSERT(num_built == num_chars);
2986 ASSERT(num_eaten == ap->len);
2987 BIF_RET(res);
2988 }
2989
2990 /**********************************************************************/
2991
2992 /* convert a list of ascii integers to an atom */
2993
list_to_atom_1(BIF_ALIST_1)2994 BIF_RETTYPE list_to_atom_1(BIF_ALIST_1)
2995 {
2996 Eterm res;
2997 byte *buf = (byte *) erts_alloc(ERTS_ALC_T_TMP, MAX_ATOM_SZ_LIMIT);
2998 Sint written;
2999 int i = erts_unicode_list_to_buf(BIF_ARG_1, buf, MAX_ATOM_CHARACTERS,
3000 &written);
3001 if (i < 0) {
3002 erts_free(ERTS_ALC_T_TMP, (void *) buf);
3003 if (i == -2) {
3004 BIF_ERROR(BIF_P, SYSTEM_LIMIT);
3005 }
3006 BIF_ERROR(BIF_P, BADARG);
3007 }
3008 res = erts_atom_put(buf, written, ERTS_ATOM_ENC_UTF8, 1);
3009 ASSERT(is_atom(res));
3010 erts_free(ERTS_ALC_T_TMP, (void *) buf);
3011 BIF_RET(res);
3012 }
3013
3014 /* conditionally convert a list of ascii integers to an atom */
3015
list_to_existing_atom_1(BIF_ALIST_1)3016 BIF_RETTYPE list_to_existing_atom_1(BIF_ALIST_1)
3017 {
3018 byte *buf = (byte *) erts_alloc(ERTS_ALC_T_TMP, MAX_ATOM_SZ_LIMIT);
3019 Sint written;
3020 int i = erts_unicode_list_to_buf(BIF_ARG_1, buf, MAX_ATOM_CHARACTERS,
3021 &written);
3022 if (i < 0) {
3023 error:
3024 erts_free(ERTS_ALC_T_TMP, (void *) buf);
3025 BIF_ERROR(BIF_P, BADARG);
3026 } else {
3027 Eterm a;
3028
3029 if (erts_atom_get((char *) buf, written, &a, ERTS_ATOM_ENC_UTF8)) {
3030 erts_free(ERTS_ALC_T_TMP, (void *) buf);
3031 BIF_RET(a);
3032 } else {
3033 goto error;
3034 }
3035 }
3036 }
3037
3038
3039 /**********************************************************************/
3040
3041 /* convert an integer to a list of ascii integers */
3042
integer_to_list(Process * c_p,Eterm num,int base)3043 static Eterm integer_to_list(Process *c_p, Eterm num, int base)
3044 {
3045 Eterm *hp;
3046 Eterm res;
3047 Uint need;
3048
3049 if (is_small(num)) {
3050 char s[128];
3051 char *c = s;
3052 Uint digits;
3053
3054 digits = Sint_to_buf(signed_val(num), base, &c, sizeof(s));
3055 need = 2 * digits;
3056
3057 hp = HAlloc(c_p, need);
3058 res = buf_to_intlist(&hp, c, digits, NIL);
3059 } else {
3060 const int DIGITS_PER_RED = 16;
3061 Eterm *hp_end;
3062 Uint digits;
3063
3064 digits = big_integer_estimate(num, base);
3065
3066 if ((digits / DIGITS_PER_RED) > ERTS_BIF_REDS_LEFT(c_p)) {
3067 ErtsSchedulerData *esdp = erts_get_scheduler_data();
3068
3069 /* This could take a very long time, tell the caller to reschedule
3070 * us to a dirty CPU scheduler if we aren't already on one. */
3071 if (esdp->type == ERTS_SCHED_NORMAL) {
3072 return THE_NON_VALUE;
3073 }
3074 } else {
3075 BUMP_REDS(c_p, digits / DIGITS_PER_RED);
3076 }
3077
3078 need = 2 * digits;
3079
3080 hp = HAlloc(c_p, need);
3081 hp_end = hp + need;
3082
3083 res = erts_big_to_list(num, base, &hp);
3084 HRelease(c_p, hp_end, hp);
3085 }
3086
3087 return res;
3088 }
3089
integer_to_list_1(BIF_ALIST_1)3090 BIF_RETTYPE integer_to_list_1(BIF_ALIST_1)
3091 {
3092 Eterm res;
3093
3094 if (is_not_integer(BIF_ARG_1)) {
3095 BIF_ERROR(BIF_P, BADARG);
3096 }
3097
3098 res = integer_to_list(BIF_P, BIF_ARG_1, 10);
3099
3100 if (is_non_value(res)) {
3101 Eterm args[1];
3102 args[0] = BIF_ARG_1;
3103 return erts_schedule_bif(BIF_P,
3104 args,
3105 BIF_I,
3106 integer_to_list_1,
3107 ERTS_SCHED_DIRTY_CPU,
3108 am_erlang,
3109 am_integer_to_list,
3110 1);
3111 }
3112
3113 return res;
3114 }
3115
integer_to_list_2(BIF_ALIST_2)3116 BIF_RETTYPE integer_to_list_2(BIF_ALIST_2)
3117 {
3118 Eterm res;
3119 SWord base;
3120
3121 if (is_not_integer(BIF_ARG_1) || is_not_small(BIF_ARG_2)) {
3122 BIF_ERROR(BIF_P, BADARG);
3123 }
3124
3125 base = signed_val(BIF_ARG_2);
3126 if (base < 2 || base > 36) {
3127 BIF_ERROR(BIF_P, BADARG);
3128 }
3129
3130 res = integer_to_list(BIF_P, BIF_ARG_1, base);
3131
3132 if (is_non_value(res)) {
3133 Eterm args[2];
3134 args[0] = BIF_ARG_1;
3135 args[1] = BIF_ARG_2;
3136 return erts_schedule_bif(BIF_P,
3137 args,
3138 BIF_I,
3139 integer_to_list_2,
3140 ERTS_SCHED_DIRTY_CPU,
3141 am_erlang,
3142 am_integer_to_list,
3143 2);
3144 }
3145
3146 return res;
3147 }
3148
3149 /**********************************************************************/
3150
3151 /*
3152 * Converts a list of ascii base10 digits to an integer fully or partially.
3153 * Returns result and the remaining tail.
3154 * On error returns: {error,not_a_list}, or {error, no_integer}
3155 */
3156
string_list_to_integer_1(BIF_ALIST_1)3157 BIF_RETTYPE string_list_to_integer_1(BIF_ALIST_1)
3158 {
3159 Eterm res;
3160 Eterm tail;
3161 Eterm *hp;
3162 /* must be a list */
3163 switch (erts_list_to_integer(BIF_P, BIF_ARG_1, 10, &res, &tail)) {
3164 /* HAlloc after erts_list_to_integer as it might HAlloc itself (bignum) */
3165 case LTI_BAD_STRUCTURE:
3166 hp = HAlloc(BIF_P,3);
3167 BIF_RET(TUPLE2(hp, am_error, am_not_a_list));
3168 case LTI_NO_INTEGER:
3169 hp = HAlloc(BIF_P,3);
3170 BIF_RET(TUPLE2(hp, am_error, am_no_integer));
3171 default:
3172 hp = HAlloc(BIF_P,3);
3173 BIF_RET(TUPLE2(hp, res, tail));
3174 }
3175 }
3176
list_to_integer_1(BIF_ALIST_1)3177 BIF_RETTYPE list_to_integer_1(BIF_ALIST_1)
3178 {
3179 /* Using erts_list_to_integer is about twice as fast as using
3180 erts_chars_to_integer because we do not have to copy the
3181 entire list */
3182 Eterm res;
3183 Eterm dummy;
3184 /* must be a list */
3185 if (erts_list_to_integer(BIF_P, BIF_ARG_1, 10,
3186 &res, &dummy) != LTI_ALL_INTEGER) {
3187 BIF_ERROR(BIF_P,BADARG);
3188 }
3189 BIF_RET(res);
3190 }
3191
list_to_integer_2(BIF_ALIST_2)3192 BIF_RETTYPE list_to_integer_2(BIF_ALIST_2)
3193 {
3194 /* Bif implementation is about 50% faster than pure erlang,
3195 and since we have erts_chars_to_integer now it is simpler
3196 as well. This could be optmized further if we did not have to
3197 copy the list to buf. */
3198 Sint i;
3199 Eterm res, dummy;
3200 int base;
3201
3202 i = erts_list_length(BIF_ARG_1);
3203 if (i < 0 || is_not_small(BIF_ARG_2)) {
3204 BIF_ERROR(BIF_P, BADARG);
3205 }
3206
3207 base = signed_val(BIF_ARG_2);
3208
3209 if (base < 2 || base > 36) {
3210 BIF_ERROR(BIF_P, BADARG);
3211 }
3212
3213 if (erts_list_to_integer(BIF_P, BIF_ARG_1, base,
3214 &res, &dummy) != LTI_ALL_INTEGER) {
3215 BIF_ERROR(BIF_P,BADARG);
3216 }
3217 BIF_RET(res);
3218 }
3219
3220 /**********************************************************************/
3221
do_float_to_charbuf(Process * p,Eterm efloat,Eterm list,char * fbuf,int sizeof_fbuf)3222 static int do_float_to_charbuf(Process *p, Eterm efloat, Eterm list,
3223 char *fbuf, int sizeof_fbuf) {
3224
3225 Eterm arity_two = make_arityval(2);
3226 int decimals = SYS_DEFAULT_FLOAT_DECIMALS;
3227 int compact = 0;
3228 enum fmt_type_ {
3229 FMT_LEGACY,
3230 FMT_FIXED,
3231 FMT_SCIENTIFIC
3232 } fmt_type = FMT_LEGACY;
3233 Eterm arg;
3234 FloatDef f;
3235
3236 /* check the arguments */
3237 if (is_not_float(efloat))
3238 goto badarg;
3239
3240 for(; is_list(list); list = CDR(list_val(list))) {
3241 arg = CAR(list_val(list));
3242 if (arg == am_compact) {
3243 compact = 1;
3244 continue;
3245 } else if (is_tuple(arg)) {
3246 Eterm* tp = tuple_val(arg);
3247 if (*tp == arity_two && is_small(tp[2])) {
3248 decimals = signed_val(tp[2]);
3249 switch (tp[1]) {
3250 case am_decimals:
3251 fmt_type = FMT_FIXED;
3252 continue;
3253 case am_scientific:
3254 fmt_type = FMT_SCIENTIFIC;
3255 continue;
3256 }
3257 }
3258 }
3259 goto badarg;
3260 }
3261 if (is_not_nil(list)) {
3262 goto badarg;
3263 }
3264
3265 GET_DOUBLE(efloat, f);
3266
3267 if (fmt_type == FMT_FIXED) {
3268 return sys_double_to_chars_fast(f.fd, fbuf, sizeof_fbuf,
3269 decimals, compact);
3270 } else {
3271 return sys_double_to_chars_ext(f.fd, fbuf, sizeof_fbuf, decimals);
3272 }
3273
3274 badarg:
3275 return -1;
3276 }
3277
3278 /* convert a float to a list of ascii characters */
3279
do_float_to_list(Process * BIF_P,Eterm arg,Eterm opts)3280 static BIF_RETTYPE do_float_to_list(Process *BIF_P, Eterm arg, Eterm opts) {
3281 int used;
3282 Eterm* hp;
3283 char fbuf[256];
3284
3285 if ((used = do_float_to_charbuf(BIF_P,arg,opts,fbuf,sizeof(fbuf))) <= 0) {
3286 BIF_ERROR(BIF_P, BADARG);
3287 }
3288 hp = HAlloc(BIF_P, (Uint)used*2);
3289 BIF_RET(buf_to_intlist(&hp, fbuf, (Uint)used, NIL));
3290 }
3291
3292
float_to_list_1(BIF_ALIST_1)3293 BIF_RETTYPE float_to_list_1(BIF_ALIST_1)
3294 {
3295 return do_float_to_list(BIF_P,BIF_ARG_1,NIL);
3296 }
3297
float_to_list_2(BIF_ALIST_2)3298 BIF_RETTYPE float_to_list_2(BIF_ALIST_2)
3299 {
3300 return do_float_to_list(BIF_P,BIF_ARG_1,BIF_ARG_2);
3301 }
3302
3303 /* convert a float to a binary of ascii characters */
3304
do_float_to_binary(Process * BIF_P,Eterm arg,Eterm opts)3305 static BIF_RETTYPE do_float_to_binary(Process *BIF_P, Eterm arg, Eterm opts) {
3306 int used;
3307 char fbuf[256];
3308
3309 if ((used = do_float_to_charbuf(BIF_P,arg,opts,fbuf,sizeof(fbuf))) <= 0) {
3310 BIF_ERROR(BIF_P, BADARG);
3311 }
3312 BIF_RET(new_binary(BIF_P, (byte*)fbuf, (Uint)used));
3313 }
3314
float_to_binary_1(BIF_ALIST_1)3315 BIF_RETTYPE float_to_binary_1(BIF_ALIST_1)
3316 {
3317 return do_float_to_binary(BIF_P,BIF_ARG_1,NIL);
3318 }
3319
float_to_binary_2(BIF_ALIST_2)3320 BIF_RETTYPE float_to_binary_2(BIF_ALIST_2)
3321 {
3322 return do_float_to_binary(BIF_P,BIF_ARG_1,BIF_ARG_2);
3323 }
3324
3325 /**********************************************************************/
3326
3327 /* convert a list of ascii integer values e's +'s and -'s to a float */
3328
3329
3330 #define SIGN 0
3331 #define INT 1
3332 #define FRAC 2
3333 #define EXP_SIGN 3
3334 #define EXP0 4
3335 #define EXP1 5
3336 #define END 6
3337
3338 #define IS_DOT(x) (unsigned_val((x)) == '.' || unsigned_val((x)) == ',')
3339 #define IS_E(x) (unsigned_val((x)) == 'e' || unsigned_val((x)) == 'E')
3340 #define IS_DIGIT(x) (unsigned_val((x)) >= '0' && unsigned_val((x)) <= '9')
3341 #define SAVE_E(xi,xim,xl,xlm) ((xim)=(xi), (xlm)=(xl))
3342 #define LOAD_E(xi,xim,xl,xlm) ((xi)=(xim), (xl)=(xlm))
3343
3344 #define STRING_TO_FLOAT_BUF_INC_SZ (128)
string_list_to_float_1(BIF_ALIST_1)3345 BIF_RETTYPE string_list_to_float_1(BIF_ALIST_1)
3346 {
3347 Eterm orig = BIF_ARG_1;
3348 Eterm list = orig;
3349 Eterm list_mem = list;
3350 int i = 0;
3351 int i_mem = 0;
3352 Eterm* hp;
3353 Eterm error_res = NIL;
3354 int part = SIGN; /* expect a + or - (or a digit) first */
3355 FloatDef f;
3356 Eterm tup;
3357 byte *buf = NULL;
3358 Uint bufsz = STRING_TO_FLOAT_BUF_INC_SZ;
3359
3360 /* check it's a valid list to start with */
3361 if (is_nil(list)) {
3362 error_res = am_no_float;
3363 error:
3364 if (buf)
3365 erts_free(ERTS_ALC_T_TMP, (void *) buf);
3366 hp = HAlloc(BIF_P, 3);
3367 BIF_RET(TUPLE2(hp, am_error, error_res));
3368 }
3369 if (is_not_list(list)) {
3370 error_res = am_not_a_list;
3371 goto error;
3372 }
3373
3374 buf = (byte *) erts_alloc(ERTS_ALC_T_TMP, bufsz);
3375
3376 /*
3377 The float might start with a SIGN (+ | -). It must contain an integer
3378 part, INT, followed by a delimiter (. | ,) and a fractional, FRAC,
3379 part. The float might also contain an exponent. If e or E indicates
3380 this we will look for a possible EXP_SIGN (+ | -) followed by the
3381 exponential number, EXP. (EXP0 is the first digit and EXP1 the rest).
3382
3383 When we encounter an expected e or E, we can't tell if it's part of
3384 the float or the rest of the string. We save the current position
3385 with SAVE_E. If we later find out it was not part of the float, we
3386 restore the position (end of the float) with LOAD_E.
3387 */
3388 while(1) {
3389 if (is_not_small(CAR(list_val(list))))
3390 goto back_to_e;
3391 if (CAR(list_val(list)) == make_small('-')) {
3392 switch (part) {
3393 case SIGN: /* expect integer part next */
3394 part = INT;
3395 break;
3396 case EXP_SIGN: /* expect first digit in exp */
3397 part = EXP0;
3398 break;
3399 case EXP0: /* example: "2.3e--" */
3400 LOAD_E(i, i_mem, list, list_mem);
3401 default: /* unexpected - done */
3402 part = END;
3403 }
3404 } else if (CAR(list_val(list)) == make_small('+')) {
3405 switch (part) {
3406 case SIGN: /* expect integer part next */
3407 part = INT;
3408 goto skip;
3409 case EXP_SIGN: /* expect first digit in exp */
3410 part = EXP0;
3411 break;
3412 case EXP0: /* example: "2.3e++" */
3413 LOAD_E(i, i_mem, list, list_mem);
3414 default: /* unexpected - done */
3415 part = END;
3416 }
3417 } else if (IS_DOT(CAR(list_val(list)))) { /* . or , */
3418 switch (part) {
3419 case INT: /* expect fractional part next */
3420 part = FRAC;
3421 break;
3422 case EXP_SIGN: /* example: "2.3e." */
3423 LOAD_E(i, i_mem, list, list_mem);
3424 case EXP0: /* example: "2.3e+." */
3425 LOAD_E(i, i_mem, list, list_mem);
3426 default: /* unexpected - done */
3427 part = END;
3428 }
3429 } else if (IS_E(CAR(list_val(list)))) { /* e or E */
3430 switch (part) {
3431 case FRAC: /* expect a + or - (or a digit) next */
3432 /*
3433 remember the position of e in case we find out later
3434 that it was not part of the float, e.g. "2.3eh?"
3435 */
3436 SAVE_E(i, i_mem, list, list_mem);
3437 part = EXP_SIGN;
3438 break;
3439 case EXP0: /* example: "2.3e+e" */
3440 case EXP_SIGN: /* example: "2.3ee" */
3441 LOAD_E(i, i_mem, list, list_mem);
3442 case INT: /* would like this to be ok, example "2e2",
3443 but it's not compatible with list_to_float */
3444 default: /* unexpected - done */
3445 part = END;
3446 }
3447 } else if (IS_DIGIT(CAR(list_val(list)))) { /* digit */
3448 switch (part) {
3449 case SIGN: /* got initial digit in integer part */
3450 part = INT; /* expect more digits to follow */
3451 break;
3452 case EXP_SIGN: /* expect exponential part */
3453 case EXP0: /* expect rest of exponential */
3454 part = EXP1;
3455 break;
3456 }
3457 } else /* character not part of float - done */
3458 goto back_to_e;
3459
3460 if (part == END) {
3461 if (i < 3) { /* we require a fractional part */
3462 error_res = am_no_float;
3463 goto error;
3464 }
3465 break;
3466 }
3467
3468 buf[i++] = unsigned_val(CAR(list_val(list)));
3469
3470 if (i == bufsz - 1)
3471 buf = (byte *) erts_realloc(ERTS_ALC_T_TMP,
3472 (void *) buf,
3473 bufsz += STRING_TO_FLOAT_BUF_INC_SZ);
3474 skip:
3475 list = CDR(list_val(list)); /* next element */
3476
3477 if (is_nil(list))
3478 goto back_to_e;
3479
3480 if (is_not_list(list)) {
3481 back_to_e:
3482 if (part == EXP_SIGN || part == EXP0) {
3483 LOAD_E(i, i_mem, list, list_mem);
3484 }
3485 break;
3486 }
3487 }
3488
3489 if (i == 0) { /* no float first in list */
3490 error_res = am_no_float;
3491 goto error;
3492 }
3493
3494 buf[i] = '\0'; /* null terminal */
3495 ASSERT(bufsz >= i + 1);
3496 if (sys_chars_to_double((char*) buf, &f.fd) != 0) {
3497 error_res = am_no_float;
3498 goto error;
3499 }
3500 hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT + 3);
3501 tup = TUPLE2(hp+FLOAT_SIZE_OBJECT, make_float(hp), list);
3502 PUT_DOUBLE(f, hp);
3503 erts_free(ERTS_ALC_T_TMP, (void *) buf);
3504 BIF_RET(tup);
3505 }
3506
do_charbuf_to_float(Process * BIF_P,char * buf)3507 static BIF_RETTYPE do_charbuf_to_float(Process *BIF_P,char *buf) {
3508 FloatDef f;
3509 Eterm res;
3510 Eterm* hp;
3511
3512 if (sys_chars_to_double(buf, &f.fd) != 0)
3513 BIF_ERROR(BIF_P, BADARG);
3514
3515 hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT);
3516 res = make_float(hp);
3517 PUT_DOUBLE(f, hp);
3518 BIF_RET(res);
3519
3520 }
3521
list_to_float_1(BIF_ALIST_1)3522 BIF_RETTYPE list_to_float_1(BIF_ALIST_1)
3523 {
3524 Sint i;
3525 Eterm res;
3526 char *buf = NULL;
3527
3528 i = erts_list_length(BIF_ARG_1);
3529 if (i < 0)
3530 BIF_ERROR(BIF_P, BADARG);
3531
3532 buf = (char *) erts_alloc(ERTS_ALC_T_TMP, i + 1);
3533
3534 if (intlist_to_buf(BIF_ARG_1, buf, i) < 0)
3535 goto list_to_float_1_error;
3536 buf[i] = '\0'; /* null terminal */
3537
3538 if ((res = do_charbuf_to_float(BIF_P,buf)) == THE_NON_VALUE)
3539 goto list_to_float_1_error;
3540
3541 erts_free(ERTS_ALC_T_TMP, (void *) buf);
3542 BIF_RET(res);
3543
3544 list_to_float_1_error:
3545 erts_free(ERTS_ALC_T_TMP, (void *) buf);
3546 BIF_ERROR(BIF_P, BADARG);
3547
3548 }
3549
binary_to_float_1(BIF_ALIST_1)3550 BIF_RETTYPE binary_to_float_1(BIF_ALIST_1)
3551 {
3552 Eterm res;
3553 Eterm binary = BIF_ARG_1;
3554 Sint size;
3555 byte* bytes, *buf;
3556 Eterm* real_bin;
3557 Uint offs = 0;
3558 Uint bit_offs = 0;
3559
3560 if (is_not_binary(binary) || (size = binary_size(binary)) == 0)
3561 BIF_ERROR(BIF_P, BADARG);
3562
3563 /*
3564 * Unfortunately we have to copy the binary because we have to insert
3565 * the '\0' at the end of the binary for strtod to work
3566 * (there is no nstrtod :( )
3567 */
3568
3569 buf = erts_alloc(ERTS_ALC_T_TMP, size + 1);
3570
3571 real_bin = binary_val(binary);
3572 if (*real_bin == HEADER_SUB_BIN) {
3573 ErlSubBin* sb = (ErlSubBin *) real_bin;
3574 if (sb->bitsize) {
3575 goto binary_to_float_1_error;
3576 }
3577 offs = sb->offs;
3578 bit_offs = sb->bitoffs;
3579 real_bin = binary_val(sb->orig);
3580 }
3581 if (*real_bin == HEADER_PROC_BIN) {
3582 bytes = ((ProcBin *) real_bin)->bytes + offs;
3583 } else {
3584 bytes = (byte *)(&(((ErlHeapBin *) real_bin)->data)) + offs;
3585 }
3586 if (bit_offs)
3587 erts_copy_bits(bytes, bit_offs, 1, buf, 0, 1, size*8);
3588 else
3589 sys_memcpy(buf, bytes, size);
3590
3591 buf[size] = '\0';
3592
3593 if ((res = do_charbuf_to_float(BIF_P,(char*)buf)) == THE_NON_VALUE)
3594 goto binary_to_float_1_error;
3595
3596 erts_free(ERTS_ALC_T_TMP, (void *) buf);
3597 BIF_RET(res);
3598
3599 binary_to_float_1_error:
3600 erts_free(ERTS_ALC_T_TMP, (void *) buf);
3601 BIF_ERROR(BIF_P, BADARG);
3602 }
3603
3604 /**********************************************************************/
3605
3606 /* convert a tuple to a list */
3607
tuple_to_list_1(BIF_ALIST_1)3608 BIF_RETTYPE tuple_to_list_1(BIF_ALIST_1)
3609 {
3610 Uint n;
3611 Eterm *tupleptr;
3612 Eterm list = NIL;
3613 Eterm* hp;
3614
3615 if (is_not_tuple(BIF_ARG_1)) {
3616 BIF_ERROR(BIF_P, BADARG);
3617 }
3618
3619 tupleptr = tuple_val(BIF_ARG_1);
3620 n = arityval(*tupleptr);
3621 hp = HAlloc(BIF_P, 2 * n);
3622 tupleptr++;
3623
3624 while(n--) {
3625 list = CONS(hp, tupleptr[n], list);
3626 hp += 2;
3627 }
3628 BIF_RET(list);
3629 }
3630
3631 /**********************************************************************/
3632
3633 /* convert a list to a tuple */
3634
list_to_tuple_1(BIF_ALIST_1)3635 BIF_RETTYPE list_to_tuple_1(BIF_ALIST_1)
3636 {
3637 Eterm list = BIF_ARG_1;
3638 Eterm* cons;
3639 Eterm res;
3640 Eterm* hp;
3641 Sint len;
3642
3643 if ((len = erts_list_length(list)) < 0 || len > ERTS_MAX_TUPLE_SIZE) {
3644 BIF_ERROR(BIF_P, BADARG);
3645 }
3646
3647 hp = HAlloc(BIF_P, len+1);
3648 res = make_tuple(hp);
3649 *hp++ = make_arityval(len);
3650 while(is_list(list)) {
3651 cons = list_val(list);
3652 *hp++ = CAR(cons);
3653 list = CDR(cons);
3654 }
3655 BIF_RET(res);
3656 }
3657
3658 /**********************************************************************/
3659
3660 /* return the pid of our own process, in most cases this has been replaced by
3661 a machine instruction */
3662
self_0(BIF_ALIST_0)3663 BIF_RETTYPE self_0(BIF_ALIST_0)
3664 {
3665 BIF_RET(BIF_P->common.id);
3666 }
3667
3668 /**********************************************************************/
3669
3670 /* return the time of day */
3671
time_0(BIF_ALIST_0)3672 BIF_RETTYPE time_0(BIF_ALIST_0)
3673 {
3674 int hour, minute, second;
3675 Eterm* hp;
3676
3677 get_time(&hour, &minute, &second);
3678 hp = HAlloc(BIF_P, 4); /* {hour, minute, second} + arity */
3679 BIF_RET(TUPLE3(hp, make_small(hour), make_small(minute),
3680 make_small(second)));
3681 }
3682 /**********************************************************************/
3683
3684 /* return the date */
3685
date_0(BIF_ALIST_0)3686 BIF_RETTYPE date_0(BIF_ALIST_0)
3687 {
3688 int year, month, day;
3689 Eterm* hp;
3690
3691 get_date(&year, &month, &day);
3692 hp = HAlloc(BIF_P, 4); /* {year, month, day} + arity */
3693 BIF_RET(TUPLE3(hp, make_small(year), make_small(month), make_small(day)));
3694 }
3695
3696 /**********************************************************************/
3697
3698 /* return the universal time */
3699
universaltime_0(BIF_ALIST_0)3700 BIF_RETTYPE universaltime_0(BIF_ALIST_0)
3701 {
3702 int year, month, day;
3703 int hour, minute, second;
3704 Eterm res1, res2;
3705 Eterm* hp;
3706
3707 /* read the clock */
3708 get_universaltime(&year, &month, &day, &hour, &minute, &second);
3709
3710 hp = HAlloc(BIF_P, 4+4+3);
3711
3712 /* and return the tuple */
3713 res1 = TUPLE3(hp,make_small(year),make_small(month),make_small(day));
3714 hp += 4;
3715 res2 = TUPLE3(hp,make_small(hour),make_small(minute),make_small(second));
3716 hp += 4;
3717 BIF_RET(TUPLE2(hp, res1, res2));
3718 }
3719
3720 /**********************************************************************/
3721
3722 /* return the universal time */
3723
localtime_0(BIF_ALIST_0)3724 BIF_RETTYPE localtime_0(BIF_ALIST_0)
3725 {
3726 int year, month, day;
3727 int hour, minute, second;
3728 Eterm res1, res2;
3729 Eterm* hp;
3730
3731 /* read the clock */
3732 get_localtime(&year, &month, &day, &hour, &minute, &second);
3733
3734 hp = HAlloc(BIF_P, 4+4+3);
3735
3736 /* and return the tuple */
3737 res1 = TUPLE3(hp,make_small(year),make_small(month),make_small(day));
3738 hp += 4;
3739 res2 = TUPLE3(hp,make_small(hour),make_small(minute),make_small(second));
3740 hp += 4;
3741 BIF_RET(TUPLE2(hp, res1, res2));
3742 }
3743 /**********************************************************************/
3744
3745 /* type check and extract components from a tuple on form: {{Y,M,D},{H,M,S}} */
3746 static int
time_to_parts(Eterm date,Sint * year,Sint * month,Sint * day,Sint * hour,Sint * minute,Sint * second)3747 time_to_parts(Eterm date, Sint* year, Sint* month, Sint* day,
3748 Sint* hour, Sint* minute, Sint* second)
3749 {
3750 Eterm* t1;
3751 Eterm* t2;
3752
3753 if (is_not_tuple(date)) {
3754 return 0;
3755 }
3756 t1 = tuple_val(date);
3757 if (arityval(t1[0]) !=2 ||
3758 is_not_tuple(t1[1]) || is_not_tuple(t1[2]))
3759 return 0;
3760 t2 = tuple_val(t1[1]);
3761 t1 = tuple_val(t1[2]);
3762 if (arityval(t2[0]) != 3 ||
3763 is_not_small(t2[1]) || is_not_small(t2[2]) || is_not_small(t2[3]))
3764 return 0;
3765 *year = signed_val(t2[1]);
3766 *month = signed_val(t2[2]);
3767 *day = signed_val(t2[3]);
3768 if (arityval(t1[0]) != 3 ||
3769 is_not_small(t1[1]) || is_not_small(t1[2]) || is_not_small(t1[3]))
3770 return 0;
3771 *hour = signed_val(t1[1]);
3772 *minute = signed_val(t1[2]);
3773 *second = signed_val(t1[3]);
3774 return 1;
3775 }
3776
3777
3778 /* return the universal time */
3779
3780 BIF_RETTYPE
localtime_to_universaltime_2(BIF_ALIST_2)3781 localtime_to_universaltime_2(BIF_ALIST_2)
3782 {
3783 Process *p = BIF_P;
3784 Eterm localtime = BIF_ARG_1;
3785 Eterm dst = BIF_ARG_2;
3786 Sint year, month, day;
3787 Sint hour, minute, second;
3788 int isdst;
3789 Eterm res1, res2;
3790 Eterm* hp;
3791
3792 if (dst == am_true) isdst = 1;
3793 else if (dst == am_false) isdst = 0;
3794 else if (dst == am_undefined) isdst = -1;
3795 else goto error;
3796
3797 if (!time_to_parts(localtime, &year, &month, &day,
3798 &hour, &minute, &second)) goto error;
3799 if (!local_to_univ(&year, &month, &day,
3800 &hour, &minute, &second, isdst)) goto error;
3801
3802 hp = HAlloc(p, 4+4+3);
3803 res1 = TUPLE3(hp,make_small(year),make_small(month),
3804 make_small(day));
3805 hp += 4;
3806 res2 = TUPLE3(hp,make_small(hour),make_small(minute),
3807 make_small(second));
3808 hp += 4;
3809 BIF_RET(TUPLE2(hp, res1, res2));
3810 error:
3811 BIF_ERROR(p, BADARG);
3812 }
3813
3814
3815 /**********************************************************************/
3816
3817 /* return the universal time */
3818
universaltime_to_localtime_1(BIF_ALIST_1)3819 BIF_RETTYPE universaltime_to_localtime_1(BIF_ALIST_1)
3820 {
3821 Sint year, month, day;
3822 Sint hour, minute, second;
3823 Eterm res1, res2;
3824 Eterm* hp;
3825
3826 if (!time_to_parts(BIF_ARG_1, &year, &month, &day,
3827 &hour, &minute, &second))
3828 BIF_ERROR(BIF_P, BADARG);
3829 if (!univ_to_local(&year, &month, &day,
3830 &hour, &minute, &second))
3831 BIF_ERROR(BIF_P, BADARG);
3832
3833 hp = HAlloc(BIF_P, 4+4+3);
3834 res1 = TUPLE3(hp,make_small(year),make_small(month),
3835 make_small(day));
3836 hp += 4;
3837 res2 = TUPLE3(hp,make_small(hour),make_small(minute),
3838 make_small(second));
3839 hp += 4;
3840 BIF_RET(TUPLE2(hp, res1, res2));
3841 }
3842
3843 /* convert calendar:universaltime_to_seconds/1 */
3844
universaltime_to_posixtime_1(BIF_ALIST_1)3845 BIF_RETTYPE universaltime_to_posixtime_1(BIF_ALIST_1)
3846 {
3847 Sint year, month, day;
3848 Sint hour, minute, second;
3849
3850 Sint64 seconds = 0;
3851 Eterm *hp;
3852 Uint hsz = 0;
3853
3854 if (!time_to_parts(BIF_ARG_1, &year, &month, &day,
3855 &hour, &minute, &second))
3856 BIF_ERROR(BIF_P, BADARG);
3857
3858 if (!univ_to_seconds(year, month, day, hour, minute, second, &seconds)) {
3859 BIF_ERROR(BIF_P, BADARG);
3860 }
3861
3862 erts_bld_sint64(NULL, &hsz, seconds);
3863 hp = HAlloc(BIF_P, hsz);
3864 BIF_RET(erts_bld_sint64(&hp, NULL, seconds));
3865 }
3866
3867 /* convert calendar:seconds_to_universaltime/1 */
3868
posixtime_to_universaltime_1(BIF_ALIST_1)3869 BIF_RETTYPE posixtime_to_universaltime_1(BIF_ALIST_1)
3870 {
3871 Sint year, month, day;
3872 Sint hour, minute, second;
3873 Eterm res1, res2;
3874 Eterm* hp;
3875
3876 Sint64 time = 0;
3877
3878 if (!term_to_Sint64(BIF_ARG_1, &time)) {
3879 BIF_ERROR(BIF_P, BADARG);
3880 }
3881
3882 if (!seconds_to_univ(time, &year, &month, &day,
3883 &hour, &minute, &second)) {
3884 BIF_ERROR(BIF_P, BADARG);
3885 }
3886
3887 hp = HAlloc(BIF_P, 4+4+3);
3888 res1 = TUPLE3(hp,make_small(year),make_small(month),
3889 make_small(day));
3890 hp += 4;
3891 res2 = TUPLE3(hp,make_small(hour),make_small(minute),
3892 make_small(second));
3893 hp += 4;
3894 BIF_RET(TUPLE2(hp, res1, res2));
3895 }
3896
3897
3898 /**********************************************************************/
3899
3900
3901 /* return a timestamp */
now_0(BIF_ALIST_0)3902 BIF_RETTYPE now_0(BIF_ALIST_0)
3903 {
3904 Uint megasec, sec, microsec;
3905 Eterm* hp;
3906
3907 get_now(&megasec, &sec, µsec);
3908 hp = HAlloc(BIF_P, 4);
3909 BIF_RET(TUPLE3(hp, make_small(megasec), make_small(sec),
3910 make_small(microsec)));
3911 }
3912
3913 /**********************************************************************/
3914
3915 /*
3916 * Pass atom 'minor' for relaxed generational GC run. This is only
3917 * recommendation, major run may still be chosen by VM.
3918 * Pass atom 'major' for default behaviour - major GC run (fullsweep)
3919 */
3920 BIF_RETTYPE
erts_internal_garbage_collect_1(BIF_ALIST_1)3921 erts_internal_garbage_collect_1(BIF_ALIST_1)
3922 {
3923 switch (BIF_ARG_1) {
3924 case am_minor: break;
3925 case am_major: FLAGS(BIF_P) |= F_NEED_FULLSWEEP; break;
3926 default: BIF_ERROR(BIF_P, BADARG);
3927 }
3928 erts_garbage_collect(BIF_P, 0, NULL, 0);
3929 if (ERTS_PROC_IS_EXITING(BIF_P)) {
3930 /* The max heap size limit was reached. */
3931 return THE_NON_VALUE;
3932 }
3933 return am_true;
3934 }
3935
3936 /**********************************************************************/
3937 /*
3938 * The erlang:processes/0 BIF.
3939 */
3940
processes_0(BIF_ALIST_0)3941 BIF_RETTYPE processes_0(BIF_ALIST_0)
3942 {
3943 return erts_ptab_list(BIF_P, &erts_proc);
3944 }
3945
3946 /**********************************************************************/
3947 /*
3948 * The erlang:ports/0 BIF.
3949 */
3950
ports_0(BIF_ALIST_0)3951 BIF_RETTYPE ports_0(BIF_ALIST_0)
3952 {
3953 return erts_ptab_list(BIF_P, &erts_port);
3954 }
3955
3956 /**********************************************************************/
3957
throw_1(BIF_ALIST_1)3958 BIF_RETTYPE throw_1(BIF_ALIST_1)
3959 {
3960 BIF_P->fvalue = BIF_ARG_1;
3961 BIF_ERROR(BIF_P, EXC_THROWN);
3962 }
3963
3964 /**********************************************************************/
3965
3966
3967 /*
3968 * Non-standard, undocumented, dirty BIF, meant for debugging.
3969 *
3970 */
display_1(BIF_ALIST_1)3971 BIF_RETTYPE display_1(BIF_ALIST_1)
3972 {
3973 erts_printf("%.*T\n", INT_MAX, BIF_ARG_1);
3974 BIF_RET(am_true);
3975 }
3976
3977 /*
3978 * erts_debug:display/1 is for debugging erlang:display/1
3979 */
erts_debug_display_1(BIF_ALIST_1)3980 BIF_RETTYPE erts_debug_display_1(BIF_ALIST_1)
3981 {
3982 int pres;
3983 Eterm res;
3984 Eterm *hp;
3985 erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(64);
3986 pres = erts_dsprintf(dsbufp, "%.*T\n", INT_MAX, BIF_ARG_1);
3987 if (pres < 0)
3988 erts_exit(ERTS_ERROR_EXIT, "Failed to convert term to string: %d (%s)\n",
3989 -pres, erl_errno_id(-pres));
3990 hp = HAlloc(BIF_P, 2*dsbufp->str_len); /* we need length * 2 heap words */
3991 res = buf_to_intlist(&hp, dsbufp->str, dsbufp->str_len, NIL);
3992 erts_printf("%s", dsbufp->str);
3993 erts_destroy_tmp_dsbuf(dsbufp);
3994 BIF_RET(res);
3995 }
3996
3997
display_string_1(BIF_ALIST_1)3998 BIF_RETTYPE display_string_1(BIF_ALIST_1)
3999 {
4000 Process* p = BIF_P;
4001 Eterm string = BIF_ARG_1;
4002 Sint len = erts_unicode_list_to_buf_len(string);
4003 Sint written;
4004 byte *str;
4005 int res;
4006
4007 if (len < 0) {
4008 BIF_ERROR(p, BADARG);
4009 }
4010 str = (byte *) erts_alloc(ERTS_ALC_T_TMP, sizeof(char)*(len + 1));
4011 res = erts_unicode_list_to_buf(string, str, len, &written);
4012 if (res != 0 || written != len)
4013 erts_exit(ERTS_ERROR_EXIT, "%s:%d: Internal error (%d)\n", __FILE__, __LINE__, res);
4014 str[len] = '\0';
4015 erts_fprintf(stderr, "%s", str);
4016 erts_free(ERTS_ALC_T_TMP, (void *) str);
4017 BIF_RET(am_true);
4018 }
4019
display_nl_0(BIF_ALIST_0)4020 BIF_RETTYPE display_nl_0(BIF_ALIST_0)
4021 {
4022 erts_fprintf(stderr, "\n");
4023 BIF_RET(am_true);
4024 }
4025
4026 /**********************************************************************/
4027
4028
4029 /* stop the system with exit code and flags */
halt_2(BIF_ALIST_2)4030 BIF_RETTYPE halt_2(BIF_ALIST_2)
4031 {
4032 Uint code;
4033 Eterm optlist = BIF_ARG_2;
4034 int flush = 1;
4035
4036 for (optlist = BIF_ARG_2;
4037 is_list(optlist);
4038 optlist = CDR(list_val(optlist))) {
4039 Eterm *tp, opt = CAR(list_val(optlist));
4040 if (is_not_tuple(opt))
4041 goto error;
4042 tp = tuple_val(opt);
4043 if (tp[0] != make_arityval(2))
4044 goto error;
4045 if (tp[1] == am_flush) {
4046 if (tp[2] == am_true)
4047 flush = 1;
4048 else if (tp[2] == am_false)
4049 flush = 0;
4050 else
4051 goto error;
4052 }
4053 else
4054 goto error;
4055 }
4056 if (is_not_nil(optlist))
4057 goto error;
4058
4059 if (term_to_Uint_mask(BIF_ARG_1, &code)) {
4060 int pos_int_code = (int) (code & INT_MAX);
4061 VERBOSE(DEBUG_SYSTEM,
4062 ("System halted by BIF halt(%T, %T)\n", BIF_ARG_1, BIF_ARG_2));
4063 if (flush) {
4064 erts_halt(pos_int_code);
4065 ERTS_BIF_YIELD2(&bif_trap_export[BIF_halt_2], BIF_P, am_undefined, am_undefined);
4066 }
4067 else {
4068 erts_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
4069 erts_exit(pos_int_code, "");
4070 }
4071 }
4072 else if (ERTS_IS_ATOM_STR("abort", BIF_ARG_1)) {
4073 VERBOSE(DEBUG_SYSTEM,
4074 ("System halted by BIF halt(%T, %T)\n", BIF_ARG_1, BIF_ARG_2));
4075 erts_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
4076 erts_exit(ERTS_ABORT_EXIT, "");
4077 }
4078 else if (is_list(BIF_ARG_1) || BIF_ARG_1 == NIL) {
4079 # define HALT_MSG_SIZE 200
4080 static byte halt_msg[4*HALT_MSG_SIZE+1];
4081 Sint written;
4082
4083 if (erts_unicode_list_to_buf(BIF_ARG_1, halt_msg, HALT_MSG_SIZE,
4084 &written) == -1 ) {
4085 goto error;
4086 }
4087 ASSERT(written >= 0 && written < sizeof(halt_msg));
4088 halt_msg[written] = '\0';
4089 VERBOSE(DEBUG_SYSTEM,
4090 ("System halted by BIF halt(%T, %T)\n", BIF_ARG_1, BIF_ARG_2));
4091 erts_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
4092 erts_exit(ERTS_DUMP_EXIT, "%s\n", halt_msg);
4093 }
4094 else
4095 goto error;
4096 return NIL; /* Pedantic (lint does not know about erts_exit) */
4097 error:
4098 BIF_ERROR(BIF_P, BADARG);
4099 }
4100
4101 /**********************************************************************/
4102
function_exported_3(BIF_ALIST_3)4103 BIF_RETTYPE function_exported_3(BIF_ALIST_3)
4104 {
4105 int arity;
4106 if (is_not_atom(BIF_ARG_1) ||
4107 is_not_atom(BIF_ARG_2) ||
4108 is_not_small(BIF_ARG_3)) {
4109 BIF_ERROR(BIF_P, BADARG);
4110 }
4111 arity = signed_val(BIF_ARG_3);
4112 if (erts_find_function(BIF_ARG_1, BIF_ARG_2, arity,
4113 erts_active_code_ix()) != NULL ||
4114 erts_is_builtin(BIF_ARG_1, BIF_ARG_2, arity)) {
4115 BIF_RET(am_true);
4116 }
4117 BIF_RET(am_false);
4118 }
4119
4120 /**********************************************************************/
4121
is_builtin_3(BIF_ALIST_3)4122 BIF_RETTYPE is_builtin_3(BIF_ALIST_3)
4123 {
4124 Process* p = BIF_P;
4125 Eterm Mod = BIF_ARG_1;
4126 Eterm Name = BIF_ARG_2;
4127 Eterm Arity = BIF_ARG_3;
4128
4129 if (is_not_atom(Mod) || is_not_atom(Name) || is_not_small(Arity)) {
4130 BIF_ERROR(p, BADARG);
4131 }
4132 BIF_RET(erts_is_builtin(Mod, Name, signed_val(Arity)) ?
4133 am_true : am_false);
4134 }
4135
4136 /**********************************************************************/
4137
4138 /* NOTE: Cannot be used in all *_to_list() bifs. erts_dsprintf() prints
4139 * some terms on other formats than what is desired as results
4140 * from *_to_list() bifs.
4141 */
4142
4143 static Eterm
term2list_dsprintf(Process * p,Eterm term)4144 term2list_dsprintf(Process *p, Eterm term)
4145 {
4146 int pres;
4147 Eterm res;
4148 Eterm *hp;
4149 erts_dsprintf_buf_t *dsbufp = erts_create_tmp_dsbuf(64);
4150 pres = erts_dsprintf(dsbufp, "%T", term);
4151 if (pres < 0)
4152 erts_exit(ERTS_ERROR_EXIT, "Failed to convert term to list: %d (%s)\n",
4153 -pres, erl_errno_id(-pres));
4154 hp = HAlloc(p, 2*dsbufp->str_len); /* we need length * 2 heap words */
4155 res = buf_to_intlist(&hp, dsbufp->str, dsbufp->str_len, NIL);
4156 erts_destroy_tmp_dsbuf(dsbufp);
4157 return res;
4158 }
4159
ref_to_list_1(BIF_ALIST_1)4160 BIF_RETTYPE ref_to_list_1(BIF_ALIST_1)
4161 {
4162 if (is_not_ref(BIF_ARG_1))
4163 BIF_ERROR(BIF_P, BADARG);
4164 erts_magic_ref_save_bin(BIF_ARG_1);
4165 BIF_RET(term2list_dsprintf(BIF_P, BIF_ARG_1));
4166 }
4167
make_fun_3(BIF_ALIST_3)4168 BIF_RETTYPE make_fun_3(BIF_ALIST_3)
4169 {
4170 Eterm* hp;
4171 Sint arity;
4172
4173 if (is_not_atom(BIF_ARG_1) || is_not_atom(BIF_ARG_2) || is_not_small(BIF_ARG_3)) {
4174 error:
4175 BIF_ERROR(BIF_P, BADARG);
4176 }
4177 arity = signed_val(BIF_ARG_3);
4178 if (arity < 0) {
4179 goto error;
4180 }
4181 hp = HAlloc(BIF_P, 2);
4182 hp[0] = HEADER_EXPORT;
4183 hp[1] = (Eterm) erts_export_get_or_make_stub(BIF_ARG_1, BIF_ARG_2, (Uint) arity);
4184 BIF_RET(make_export(hp));
4185 }
4186
fun_to_list_1(BIF_ALIST_1)4187 BIF_RETTYPE fun_to_list_1(BIF_ALIST_1)
4188 {
4189 Process* p = BIF_P;
4190 Eterm fun = BIF_ARG_1;
4191
4192 if (is_not_any_fun(fun))
4193 BIF_ERROR(p, BADARG);
4194 BIF_RET(term2list_dsprintf(p, fun));
4195 }
4196
4197 /**********************************************************************/
4198
4199 /* convert a pid to an erlang list (for the linked cons cells) of the form
4200 <node.number.serial> to a PID
4201 */
4202
pid_to_list_1(BIF_ALIST_1)4203 BIF_RETTYPE pid_to_list_1(BIF_ALIST_1)
4204 {
4205 if (is_not_pid(BIF_ARG_1))
4206 BIF_ERROR(BIF_P, BADARG);
4207 BIF_RET(term2list_dsprintf(BIF_P, BIF_ARG_1));
4208 }
4209
port_to_list_1(BIF_ALIST_1)4210 BIF_RETTYPE port_to_list_1(BIF_ALIST_1)
4211 {
4212 if (is_not_port(BIF_ARG_1))
4213 BIF_ERROR(BIF_P, BADARG);
4214 BIF_RET(term2list_dsprintf(BIF_P, BIF_ARG_1));
4215 }
4216
4217 /**********************************************************************/
4218
4219 /* convert a list of ascii characeters of the form
4220 <node.number.serial> to a PID
4221 */
4222
list_to_pid_1(BIF_ALIST_1)4223 BIF_RETTYPE list_to_pid_1(BIF_ALIST_1)
4224 {
4225 Uint a = 0, b = 0, c = 0;
4226 char* cp;
4227 Sint i;
4228 DistEntry *dep = NULL;
4229 char *buf = (char *) erts_alloc(ERTS_ALC_T_TMP, 65);
4230 /*
4231 * Max 'Uint64' has 20 decimal digits. If X, Y, Z in <X.Y.Z>
4232 * are 'Uint64's. Max chars are 1 + 20 + 1 + 20 + 1 + 20 + 1 = 64,
4233 * i.e, if the input list is longer than 64 it does not represent
4234 * a pid.
4235 */
4236
4237 /* walk down the list and create a C string */
4238 if ((i = intlist_to_buf(BIF_ARG_1, buf, 64)) < 0)
4239 goto bad;
4240
4241 buf[i] = '\0'; /* null terminal */
4242
4243 cp = buf;
4244 if (*cp++ != '<') goto bad;
4245
4246 if (*cp < '0' || *cp > '9') goto bad;
4247 while(*cp >= '0' && *cp <= '9') { a = 10*a + (*cp - '0'); cp++; }
4248
4249 if (*cp++ != '.') goto bad;
4250
4251 if (*cp < '0' || *cp > '9') goto bad;
4252 while(*cp >= '0' && *cp <= '9') { b = 10*b + (*cp - '0'); cp++; }
4253
4254 if (*cp++ != '.') goto bad;
4255
4256 if (*cp < '0' || *cp > '9') goto bad;
4257 while(*cp >= '0' && *cp <= '9') { c = 10*c + (*cp - '0'); cp++; }
4258
4259 if (*cp++ != '>') goto bad;
4260 if (*cp != '\0') goto bad;
4261
4262 erts_free(ERTS_ALC_T_TMP, (void *) buf);
4263 buf = NULL;
4264
4265 /* <a.b.c> a = node, b = process number, c = serial */
4266
4267 dep = erts_channel_no_to_dist_entry(a);
4268
4269 if (!dep)
4270 goto bad;
4271
4272
4273 if (c > ERTS_MAX_PID_SERIAL || b > ERTS_MAX_PID_NUMBER)
4274 goto bad;
4275
4276 if(dep == erts_this_dist_entry) {
4277 BIF_RET(make_internal_pid(make_pid_data(c, b)));
4278 }
4279 else {
4280 ExternalThing *etp;
4281 ErlNode *enp;
4282
4283 if (is_nil(dep->cid))
4284 goto bad;
4285
4286 etp = (ExternalThing *) HAlloc(BIF_P, EXTERNAL_THING_HEAD_SIZE + 1);
4287
4288 enp = erts_find_or_insert_node(dep->sysname, dep->creation,
4289 make_boxed(&etp->header));
4290 ASSERT(enp != erts_this_node);
4291
4292 etp->header = make_external_pid_header(1);
4293 etp->next = MSO(BIF_P).first;
4294 etp->node = enp;
4295 etp->data.ui[0] = make_pid_data(c, b);
4296
4297 MSO(BIF_P).first = (struct erl_off_heap_header*) etp;
4298 BIF_RET(make_external_pid(etp));
4299 }
4300
4301 bad:
4302 if (buf)
4303 erts_free(ERTS_ALC_T_TMP, (void *) buf);
4304 BIF_ERROR(BIF_P, BADARG);
4305 }
4306
list_to_port_1(BIF_ALIST_1)4307 BIF_RETTYPE list_to_port_1(BIF_ALIST_1)
4308 {
4309 /*
4310 * A valid port identifier is on the format
4311 * "#Port<N.P>" where N is node and P is
4312 * the port id. Both N and P are of type Uint32.
4313 */
4314 Uint32 n, p;
4315 char* cp;
4316 int i;
4317 DistEntry *dep = NULL;
4318 char buf[6 /* #Port< */
4319 + (2)*(10 + 1) /* N.P> */
4320 + 1 /* \0 */];
4321
4322 /* walk down the list and create a C string */
4323 if ((i = intlist_to_buf(BIF_ARG_1, buf, sizeof(buf)-1)) < 0)
4324 goto bad;
4325
4326 buf[i] = '\0'; /* null terminal */
4327
4328 cp = &buf[0];
4329 if (sys_strncmp("#Port<", cp, 6) != 0)
4330 goto bad;
4331
4332 cp += 6; /* sys_strlen("#Port<") */
4333
4334 if (sscanf(cp, "%u.%u>", (unsigned int*)&n, (unsigned int*)&p) < 2)
4335 goto bad;
4336
4337 if (p > ERTS_MAX_PORT_NUMBER)
4338 goto bad;
4339
4340 dep = erts_channel_no_to_dist_entry(n);
4341
4342 if (!dep)
4343 goto bad;
4344
4345 if(dep == erts_this_dist_entry) {
4346 BIF_RET(make_internal_port(p));
4347 }
4348 else {
4349 ExternalThing *etp;
4350 ErlNode *enp;
4351
4352 if (is_nil(dep->cid))
4353 goto bad;
4354
4355 etp = (ExternalThing *) HAlloc(BIF_P, EXTERNAL_THING_HEAD_SIZE + 1);
4356 enp = erts_find_or_insert_node(dep->sysname, dep->creation,
4357 make_boxed(&etp->header));
4358 ASSERT(enp != erts_this_node);
4359
4360 etp->header = make_external_port_header(1);
4361 etp->next = MSO(BIF_P).first;
4362 etp->node = enp;
4363 etp->data.ui[0] = p;
4364
4365 MSO(BIF_P).first = (struct erl_off_heap_header*) etp;
4366 BIF_RET(make_external_port(etp));
4367 }
4368
4369 bad:
4370 BIF_ERROR(BIF_P, BADARG);
4371 }
4372
list_to_ref_1(BIF_ALIST_1)4373 BIF_RETTYPE list_to_ref_1(BIF_ALIST_1)
4374 {
4375 /*
4376 * A valid reference is on the format
4377 * "#Ref<N.X.Y.Z>" where N, X, Y, and Z are
4378 * 32-bit integers (i.e., max 10 characters).
4379 */
4380 Eterm *hp;
4381 Eterm res;
4382 Uint32 refn[ERTS_MAX_REF_NUMBERS];
4383 int n = 0;
4384 Uint ints[1 + ERTS_MAX_REF_NUMBERS] = {0};
4385 char* cp;
4386 Sint i;
4387 DistEntry *dep = NULL;
4388 char buf[5 /* #Ref< */
4389 + (1 + ERTS_MAX_REF_NUMBERS)*(10 + 1) /* N.X.Y.Z> */
4390 + 1 /* \0 */];
4391
4392 /* walk down the list and create a C string */
4393 if ((i = intlist_to_buf(BIF_ARG_1, buf, sizeof(buf)-1)) < 0)
4394 goto bad;
4395
4396 buf[i] = '\0'; /* null terminal */
4397
4398 cp = &buf[0];
4399 if (*cp++ != '#') goto bad;
4400 if (*cp++ != 'R') goto bad;
4401 if (*cp++ != 'e') goto bad;
4402 if (*cp++ != 'f') goto bad;
4403 if (*cp++ != '<') goto bad;
4404
4405 for (i = 0; i < sizeof(ints)/sizeof(Uint); i++) {
4406 if (*cp < '0' || *cp > '9') goto bad;
4407
4408 while (*cp >= '0' && *cp <= '9') {
4409 ints[i] = 10*ints[i] + (*cp - '0');
4410 cp++;
4411 }
4412
4413 n++;
4414 if (ints[i] > ~((Uint32) 0)) goto bad;
4415 if (*cp == '>') break;
4416 if (*cp++ != '.') goto bad;
4417 }
4418
4419 if (*cp++ != '>') goto bad;
4420 if (*cp != '\0') goto bad;
4421
4422 if (n < 2) goto bad;
4423
4424 for (n = 0; i > 0; i--)
4425 refn[n++] = (Uint32) ints[i];
4426
4427 ASSERT(n <= ERTS_MAX_REF_NUMBERS);
4428
4429 dep = erts_channel_no_to_dist_entry(ints[0]);
4430
4431 if (!dep)
4432 goto bad;
4433
4434 if(dep == erts_this_dist_entry) {
4435 ErtsMagicBinary *mb;
4436 Uint32 sid;
4437 if (refn[0] >= MAX_REFERENCE) goto bad;
4438 if (n != ERTS_REF_NUMBERS) goto bad;
4439 sid = erts_get_ref_numbers_thr_id(refn);
4440 if (sid > erts_no_schedulers) goto bad;
4441 mb = erts_magic_ref_lookup_bin(refn);
4442 if (mb) {
4443 hp = HAlloc(BIF_P, ERTS_MAGIC_REF_THING_SIZE);
4444 res = erts_mk_magic_ref(&hp, &BIF_P->off_heap,
4445 (Binary *) mb);
4446 }
4447 else {
4448 hp = HAlloc(BIF_P, ERTS_REF_THING_SIZE);
4449 write_ref_thing(hp, refn[0], refn[1], refn[2]);
4450 res = make_internal_ref(hp);
4451 }
4452 }
4453 else {
4454 ExternalThing *etp;
4455 ErlNode *enp;
4456 Uint hsz;
4457 int j;
4458
4459 if (is_nil(dep->cid))
4460 goto bad;
4461
4462 hsz = EXTERNAL_THING_HEAD_SIZE;
4463 #if defined(ARCH_64)
4464 hsz += n/2 + 1;
4465 #else
4466 hsz += n;
4467 #endif
4468
4469 etp = (ExternalThing *) HAlloc(BIF_P, hsz);
4470
4471 enp = erts_find_or_insert_node(dep->sysname, dep->creation,
4472 make_boxed(&etp->header));
4473 ASSERT(enp != erts_this_node);
4474
4475 #if defined(ARCH_64)
4476 etp->header = make_external_ref_header(n/2 + 1);
4477 #else
4478 etp->header = make_external_ref_header(n);
4479 #endif
4480 etp->next = BIF_P->off_heap.first;
4481 etp->node = enp;
4482 i = 0;
4483 #if defined(ARCH_64)
4484 etp->data.ui32[i++] = n;
4485 #endif
4486 for (j = 0; j < n; j++) {
4487 etp->data.ui32[i] = refn[j];
4488 i++;
4489 }
4490
4491 BIF_P->off_heap.first = (struct erl_off_heap_header*) etp;
4492 res = make_external_ref(etp);
4493 }
4494
4495 BIF_RET(res);
4496
4497 bad:
4498 BIF_ERROR(BIF_P, BADARG);
4499 }
4500
4501
4502 /**********************************************************************/
4503
group_leader_0(BIF_ALIST_0)4504 BIF_RETTYPE group_leader_0(BIF_ALIST_0)
4505 {
4506 BIF_RET(BIF_P->group_leader);
4507 }
4508
4509 /**********************************************************************/
4510 /* set group leader */
4511
4512 int
erts_set_group_leader(Process * proc,Eterm new_gl)4513 erts_set_group_leader(Process *proc, Eterm new_gl)
4514 {
4515
4516 erts_aint32_t state;
4517
4518 ASSERT(is_pid(new_gl));
4519
4520 state = erts_atomic32_read_nob(&proc->state);
4521
4522 if (state & ERTS_PSFLG_EXITING)
4523 return 0;
4524
4525 ERTS_LC_ASSERT(ERTS_PROC_LOCK_MAIN & erts_proc_lc_my_proc_locks(proc));
4526
4527 if (!(state & ERTS_PSFLG_DIRTY_RUNNING))
4528 proc->group_leader = STORE_NC_IN_PROC(proc, new_gl);
4529 else {
4530 ErlHeapFragment *bp;
4531 Eterm *hp;
4532 /*
4533 * Currently executing on a dirty scheduler,
4534 * so we are not allowed to write to its heap.
4535 * Store group leader pid in heap fragment.
4536 */
4537 bp = new_message_buffer(NC_HEAP_SIZE(new_gl));
4538 hp = bp->mem;
4539 proc->group_leader = STORE_NC(&hp,
4540 &proc->off_heap,
4541 new_gl);
4542 bp->next = proc->mbuf;
4543 proc->mbuf = bp;
4544 proc->mbuf_sz += bp->used_size;
4545 }
4546
4547 return !0;
4548 }
4549
erts_internal_group_leader_3(BIF_ALIST_3)4550 BIF_RETTYPE erts_internal_group_leader_3(BIF_ALIST_3)
4551 {
4552 if (is_not_pid(BIF_ARG_1))
4553 BIF_ERROR(BIF_P, BADARG);
4554 if (is_not_internal_pid(BIF_ARG_2))
4555 BIF_ERROR(BIF_P, BADARG);
4556 if (is_not_internal_ref(BIF_ARG_3))
4557 BIF_ERROR(BIF_P, BADARG);
4558
4559 erts_proc_sig_send_group_leader(BIF_P,
4560 BIF_ARG_2,
4561 BIF_ARG_1,
4562 BIF_ARG_3);
4563 BIF_RET(am_ok);
4564 }
4565
erts_internal_group_leader_2(BIF_ALIST_2)4566 BIF_RETTYPE erts_internal_group_leader_2(BIF_ALIST_2)
4567 {
4568 if (is_not_pid(BIF_ARG_1))
4569 BIF_RET(am_badarg);
4570
4571 if (is_internal_pid(BIF_ARG_2)) {
4572 Process *rp;
4573 int res;
4574
4575 if (BIF_ARG_2 == BIF_P->common.id)
4576 rp = BIF_P;
4577 else {
4578 rp = erts_try_lock_sig_free_proc(BIF_ARG_2,
4579 ERTS_PROC_LOCK_MAIN,
4580 NULL);
4581 if (!rp)
4582 BIF_RET(am_badarg);
4583 if (rp == ERTS_PROC_LOCK_BUSY)
4584 BIF_RET(am_false);
4585 }
4586
4587 res = erts_set_group_leader(rp, BIF_ARG_1);
4588
4589 if (rp != BIF_P)
4590 erts_proc_unlock(rp, ERTS_PROC_LOCK_MAIN);
4591
4592 BIF_RET(res ? am_true : am_badarg);
4593 }
4594
4595 if (is_external_pid(BIF_ARG_2)) {
4596 DistEntry *dep;
4597 int code;
4598 ErtsDSigSendContext ctx;
4599 dep = external_pid_dist_entry(BIF_ARG_2);
4600 ERTS_ASSERT(dep);
4601 if(dep == erts_this_dist_entry)
4602 BIF_ERROR(BIF_P, BADARG);
4603
4604 code = erts_dsig_prepare(&ctx, dep, BIF_P, ERTS_PROC_LOCK_MAIN,
4605 ERTS_DSP_NO_LOCK, 0, 1, 1);
4606 switch (code) {
4607 case ERTS_DSIG_PREP_NOT_ALIVE:
4608 case ERTS_DSIG_PREP_NOT_CONNECTED:
4609 BIF_RET(am_true);
4610 case ERTS_DSIG_PREP_PENDING:
4611 case ERTS_DSIG_PREP_CONNECTED:
4612 code = erts_dsig_send_group_leader(&ctx, BIF_ARG_1, BIF_ARG_2);
4613 if (code == ERTS_DSIG_SEND_YIELD)
4614 ERTS_BIF_YIELD_RETURN(BIF_P, am_true);
4615 BIF_RET(am_true);
4616 default:
4617 ERTS_ASSERT(! "Invalid dsig prepare result");
4618 }
4619 }
4620
4621 BIF_RET(am_badarg);
4622 }
4623
system_flag_2(BIF_ALIST_2)4624 BIF_RETTYPE system_flag_2(BIF_ALIST_2)
4625 {
4626 Sint n;
4627
4628 if (BIF_ARG_1 == am_multi_scheduling) {
4629 if (BIF_ARG_2 == am_block || BIF_ARG_2 == am_unblock
4630 || BIF_ARG_2 == am_block_normal || BIF_ARG_2 == am_unblock_normal) {
4631 int block = (BIF_ARG_2 == am_block
4632 || BIF_ARG_2 == am_block_normal);
4633 int normal = (BIF_ARG_2 == am_block_normal
4634 || BIF_ARG_2 == am_unblock_normal);
4635 switch (erts_block_multi_scheduling(BIF_P,
4636 ERTS_PROC_LOCK_MAIN,
4637 block,
4638 normal,
4639 0)) {
4640 case ERTS_SCHDLR_SSPND_DONE_MSCHED_BLOCKED:
4641 BIF_RET(am_blocked);
4642 case ERTS_SCHDLR_SSPND_DONE_NMSCHED_BLOCKED:
4643 BIF_RET(am_blocked_normal);
4644 case ERTS_SCHDLR_SSPND_YIELD_DONE_MSCHED_BLOCKED:
4645 ERTS_BIF_YIELD_RETURN_X(BIF_P, am_blocked,
4646 am_multi_scheduling);
4647 case ERTS_SCHDLR_SSPND_YIELD_DONE_NMSCHED_BLOCKED:
4648 ERTS_BIF_YIELD_RETURN_X(BIF_P, am_blocked_normal,
4649 am_multi_scheduling);
4650 case ERTS_SCHDLR_SSPND_DONE:
4651 BIF_RET(am_enabled);
4652 case ERTS_SCHDLR_SSPND_YIELD_RESTART:
4653 ERTS_VBUMP_ALL_REDS(BIF_P);
4654 BIF_TRAP2(&bif_trap_export[BIF_system_flag_2],
4655 BIF_P, BIF_ARG_1, BIF_ARG_2);
4656 case ERTS_SCHDLR_SSPND_YIELD_DONE:
4657 ERTS_BIF_YIELD_RETURN_X(BIF_P, am_enabled,
4658 am_multi_scheduling);
4659 case ERTS_SCHDLR_SSPND_EINVAL:
4660 goto error;
4661 default:
4662 ASSERT(0);
4663 BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR);
4664 break;
4665 }
4666 }
4667 } else if (BIF_ARG_1 == am_schedulers_online) {
4668 Sint old_no;
4669 if (!is_small(BIF_ARG_2))
4670 goto error;
4671 switch (erts_set_schedulers_online(BIF_P,
4672 ERTS_PROC_LOCK_MAIN,
4673 signed_val(BIF_ARG_2),
4674 &old_no, 0)) {
4675 case ERTS_SCHDLR_SSPND_DONE:
4676 BIF_RET(make_small(old_no));
4677 case ERTS_SCHDLR_SSPND_YIELD_RESTART:
4678 ERTS_VBUMP_ALL_REDS(BIF_P);
4679 BIF_TRAP2(&bif_trap_export[BIF_system_flag_2],
4680 BIF_P, BIF_ARG_1, BIF_ARG_2);
4681 case ERTS_SCHDLR_SSPND_YIELD_DONE:
4682 ERTS_BIF_YIELD_RETURN_X(BIF_P, make_small(old_no),
4683 am_schedulers_online);
4684 case ERTS_SCHDLR_SSPND_EINVAL:
4685 goto error;
4686 default:
4687 ASSERT(0);
4688 BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR);
4689 break;
4690 }
4691 } else if (BIF_ARG_1 == am_fullsweep_after) {
4692 Uint16 nval;
4693 Uint oval;
4694 if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) {
4695 goto error;
4696 }
4697 nval = (n > (Sint) ((Uint16) -1)) ? ((Uint16) -1) : ((Uint16) n);
4698 oval = (Uint) erts_atomic32_xchg_nob(&erts_max_gen_gcs,
4699 (erts_aint32_t) nval);
4700 BIF_RET(make_small(oval));
4701 } else if (BIF_ARG_1 == am_min_heap_size) {
4702 int oval = H_MIN_SIZE;
4703
4704 if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) {
4705 goto error;
4706 }
4707
4708 erts_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
4709 erts_thr_progress_block();
4710
4711 H_MIN_SIZE = erts_next_heap_size(n, 0);
4712
4713 erts_thr_progress_unblock();
4714 erts_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN);
4715
4716 BIF_RET(make_small(oval));
4717 } else if (BIF_ARG_1 == am_min_bin_vheap_size) {
4718 int oval = BIN_VH_MIN_SIZE;
4719
4720 if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) {
4721 goto error;
4722 }
4723
4724 erts_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
4725 erts_thr_progress_block();
4726
4727 BIN_VH_MIN_SIZE = erts_next_heap_size(n, 0);
4728
4729 erts_thr_progress_unblock();
4730 erts_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN);
4731
4732 BIF_RET(make_small(oval));
4733 } else if (BIF_ARG_1 == am_max_heap_size) {
4734
4735 Eterm *hp, old_value;
4736 Uint sz = 0, max_heap_size, max_heap_flags;
4737
4738 if (!erts_max_heap_size(BIF_ARG_2, &max_heap_size, &max_heap_flags))
4739 goto error;
4740
4741 if (max_heap_size < H_MIN_SIZE && max_heap_size != 0)
4742 goto error;
4743
4744 erts_max_heap_size_map(H_MAX_SIZE, H_MAX_FLAGS, NULL, &sz);
4745 hp = HAlloc(BIF_P, sz);
4746 old_value = erts_max_heap_size_map(H_MAX_SIZE, H_MAX_FLAGS, &hp, NULL);
4747
4748 erts_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
4749 erts_thr_progress_block();
4750
4751 H_MAX_SIZE = max_heap_size;
4752 H_MAX_FLAGS = max_heap_flags;
4753
4754 erts_thr_progress_unblock();
4755 erts_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN);
4756
4757 BIF_RET(old_value);
4758 } else if (BIF_ARG_1 == am_debug_flags) {
4759 BIF_RET(am_true);
4760 } else if (BIF_ARG_1 == am_backtrace_depth) {
4761 int oval = erts_backtrace_depth;
4762 if (!is_small(BIF_ARG_2) || (n = signed_val(BIF_ARG_2)) < 0) {
4763 goto error;
4764 }
4765 if (n > MAX_BACKTRACE_SIZE) n = MAX_BACKTRACE_SIZE;
4766 erts_backtrace_depth = n;
4767 BIF_RET(make_small(oval));
4768 } else if (BIF_ARG_1 == am_trace_control_word) {
4769 BIF_RET(db_set_trace_control_word(BIF_P, BIF_ARG_2));
4770 } else if (BIF_ARG_1 == am_sequential_tracer) {
4771 ErtsTracer new_seq_tracer, old_seq_tracer;
4772 Eterm ret;
4773
4774 if (BIF_ARG_2 == am_false)
4775 new_seq_tracer = erts_tracer_nil;
4776 else
4777 new_seq_tracer = erts_term_to_tracer(THE_NON_VALUE, BIF_ARG_2);
4778
4779 if (new_seq_tracer == THE_NON_VALUE)
4780 goto error;
4781
4782 old_seq_tracer = erts_set_system_seq_tracer(BIF_P,
4783 ERTS_PROC_LOCK_MAIN,
4784 new_seq_tracer);
4785
4786 ERTS_TRACER_CLEAR(&new_seq_tracer);
4787
4788 if (old_seq_tracer == THE_NON_VALUE)
4789 goto error;
4790
4791 if (ERTS_TRACER_IS_NIL(old_seq_tracer))
4792 BIF_RET(am_false);
4793
4794 ret = erts_tracer_to_term(BIF_P, old_seq_tracer);
4795
4796 ERTS_TRACER_CLEAR(&old_seq_tracer);
4797
4798 BIF_RET(ret);
4799 } else if (BIF_ARG_1 == am_reset_seq_trace) {
4800 int i, max;
4801
4802 erts_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
4803 erts_thr_progress_block();
4804
4805 max = erts_ptab_max(&erts_proc);
4806 for (i = 0; i < max; i++) {
4807 Process *p = erts_pix2proc(i);
4808 if (p) {
4809 #ifdef USE_VM_PROBES
4810 p->seq_trace_token = (p->dt_utag != NIL) ? am_have_dt_utag : NIL;
4811 #else
4812 p->seq_trace_token = NIL;
4813 #endif
4814 p->seq_trace_clock = 0;
4815 p->seq_trace_lastcnt = 0;
4816 erts_proc_lock(p, ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_MSGQ);
4817 erts_proc_sig_clear_seq_trace_tokens(p);
4818 erts_proc_unlock(p, ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_MSGQ);
4819 }
4820 }
4821
4822 erts_thr_progress_unblock();
4823 erts_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN);
4824
4825 BIF_RET(am_true);
4826 } else if (BIF_ARG_1 == am_scheduler_wall_time) {
4827 if (BIF_ARG_2 == am_true || BIF_ARG_2 == am_false)
4828 BIF_TRAP1(system_flag_scheduler_wall_time_trap,
4829 BIF_P, BIF_ARG_2);
4830 } else if (BIF_ARG_1 == am_dirty_cpu_schedulers_online) {
4831 Sint old_no;
4832 if (!is_small(BIF_ARG_2))
4833 goto error;
4834 switch (erts_set_schedulers_online(BIF_P,
4835 ERTS_PROC_LOCK_MAIN,
4836 signed_val(BIF_ARG_2),
4837 &old_no,
4838 1)) {
4839 case ERTS_SCHDLR_SSPND_DONE:
4840 BIF_RET(make_small(old_no));
4841 case ERTS_SCHDLR_SSPND_YIELD_RESTART:
4842 ERTS_VBUMP_ALL_REDS(BIF_P);
4843 BIF_TRAP2(&bif_trap_export[BIF_system_flag_2],
4844 BIF_P, BIF_ARG_1, BIF_ARG_2);
4845 case ERTS_SCHDLR_SSPND_YIELD_DONE:
4846 ERTS_BIF_YIELD_RETURN_X(BIF_P, make_small(old_no),
4847 am_dirty_cpu_schedulers_online);
4848 case ERTS_SCHDLR_SSPND_EINVAL:
4849 goto error;
4850 default:
4851 ASSERT(0);
4852 BIF_ERROR(BIF_P, EXC_INTERNAL_ERROR);
4853 break;
4854 }
4855 } else if (BIF_ARG_1 == am_time_offset
4856 && ERTS_IS_ATOM_STR("finalize", BIF_ARG_2)) {
4857 ErtsTimeOffsetState res;
4858 erts_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
4859 res = erts_finalize_time_offset();
4860 erts_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN);
4861 switch (res) {
4862 case ERTS_TIME_OFFSET_PRELIMINARY: {
4863 DECL_AM(preliminary);
4864 BIF_RET(AM_preliminary);
4865 }
4866 case ERTS_TIME_OFFSET_FINAL: {
4867 DECL_AM(final);
4868 BIF_RET(AM_final);
4869 }
4870 case ERTS_TIME_OFFSET_VOLATILE: {
4871 DECL_AM(volatile);
4872 BIF_RET(AM_volatile);
4873 }
4874 default:
4875 ERTS_INTERNAL_ERROR("Unknown state");
4876 }
4877 #ifdef ERTS_ENABLE_MSACC
4878 } else if (BIF_ARG_1 == am_microstate_accounting) {
4879 Eterm threads;
4880 if (BIF_ARG_2 == am_true || BIF_ARG_2 == am_false) {
4881 erts_aint32_t new = BIF_ARG_2 == am_true ? ERTS_MSACC_ENABLE : ERTS_MSACC_DISABLE;
4882 erts_aint32_t old = erts_atomic32_xchg_nob(&msacc, new);
4883 Eterm ref = erts_msacc_request(BIF_P, new, &threads);
4884 if (is_non_value(ref))
4885 BIF_RET(old ? am_true : am_false);
4886 BIF_TRAP3(await_msacc_mod_trap,
4887 BIF_P,
4888 ref,
4889 old ? am_true : am_false,
4890 threads);
4891 } else if (BIF_ARG_2 == am_reset) {
4892 Eterm ref = erts_msacc_request(BIF_P, ERTS_MSACC_RESET, &threads);
4893 erts_aint32_t old = erts_atomic32_read_nob(&msacc);
4894 ASSERT(is_value(ref));
4895 BIF_TRAP3(await_msacc_mod_trap,
4896 BIF_P,
4897 ref,
4898 old ? am_true : am_false,
4899 threads);
4900 }
4901 #endif
4902 } else if (BIF_ARG_1 == am_outstanding_system_requests_limit) {
4903 Uint val;
4904 if (!term_to_Uint(BIF_ARG_2, &val))
4905 goto error;
4906 val = erts_set_outstanding_system_requests_limit(val);
4907 if (!val)
4908 goto error;
4909 BIF_RET(make_small(val));
4910 } else if (ERTS_IS_ATOM_STR("scheduling_statistics", BIF_ARG_1)) {
4911 int what;
4912 if (ERTS_IS_ATOM_STR("disable", BIF_ARG_2))
4913 what = ERTS_SCHED_STAT_MODIFY_DISABLE;
4914 else if (ERTS_IS_ATOM_STR("enable", BIF_ARG_2))
4915 what = ERTS_SCHED_STAT_MODIFY_ENABLE;
4916 else if (ERTS_IS_ATOM_STR("clear", BIF_ARG_2))
4917 what = ERTS_SCHED_STAT_MODIFY_CLEAR;
4918 else
4919 goto error;
4920 erts_proc_unlock(BIF_P, ERTS_PROC_LOCK_MAIN);
4921 erts_sched_stat_modify(what);
4922 erts_proc_lock(BIF_P, ERTS_PROC_LOCK_MAIN);
4923 BIF_RET(am_true);
4924 } else if (ERTS_IS_ATOM_STR("internal_cpu_topology", BIF_ARG_1)) {
4925 Eterm res = erts_set_cpu_topology(BIF_P, BIF_ARG_2);
4926 if (is_value(res))
4927 BIF_RET(res);
4928 } else if (ERTS_IS_ATOM_STR("cpu_topology", BIF_ARG_1)) {
4929 erts_send_warning_to_logger_str(
4930 BIF_P->group_leader,
4931 "A call to erlang:system_flag(cpu_topology, _) was made.\n"
4932 "The cpu_topology argument is deprecated and scheduled\n"
4933 "for removal in Erlang/OTP 18. For more information\n"
4934 "see the erlang:system_flag/2 documentation.\n");
4935 BIF_TRAP1(set_cpu_topology_trap, BIF_P, BIF_ARG_2);
4936 } else if (ERTS_IS_ATOM_STR("scheduler_bind_type", BIF_ARG_1)) {
4937 erts_send_warning_to_logger_str(
4938 BIF_P->group_leader,
4939 "A call to erlang:system_flag(scheduler_bind_type, _) was\n"
4940 "made. The scheduler_bind_type argument is deprecated and\n"
4941 "scheduled for removal in Erlang/OTP 18. For more\n"
4942 "information see the erlang:system_flag/2 documentation.\n");
4943 return erts_bind_schedulers(BIF_P, BIF_ARG_2);
4944 } else if (ERTS_IS_ATOM_STR("erts_alloc", BIF_ARG_1)) {
4945 return erts_alloc_set_dyn_param(BIF_P, BIF_ARG_2);
4946 } else if (ERTS_IS_ATOM_STR("system_logger", BIF_ARG_1)) {
4947 Eterm res = erts_set_system_logger(BIF_ARG_2);
4948 if (is_value(res)) BIF_RET(res);
4949 }
4950 error:
4951 BIF_ERROR(BIF_P, BADARG);
4952 }
4953
erts_internal_scheduler_wall_time_1(BIF_ALIST_1)4954 BIF_RETTYPE erts_internal_scheduler_wall_time_1(BIF_ALIST_1)
4955 {
4956 erts_aint32_t new = BIF_ARG_1 == am_true ? 1 : 0;
4957 erts_aint32_t old = erts_atomic32_xchg_nob(&sched_wall_time,
4958 new);
4959 Eterm ref = erts_sched_wall_time_request(BIF_P, 1, new, 0, 0);
4960 ASSERT(is_value(ref));
4961 BIF_TRAP2(await_sched_wall_time_mod_trap,
4962 BIF_P, ref, old ? am_true : am_false);
4963 }
4964
4965 /**********************************************************************/
4966
phash_2(BIF_ALIST_2)4967 BIF_RETTYPE phash_2(BIF_ALIST_2)
4968 {
4969 Uint32 hash;
4970 Uint32 final_hash;
4971 Uint32 range;
4972
4973 /* Check for special case 2^32 */
4974 if (term_equals_2pow32(BIF_ARG_2)) {
4975 range = 0;
4976 } else {
4977 Uint u;
4978 if (!term_to_Uint(BIF_ARG_2, &u) || ((u >> 16) >> 16) != 0 || !u) {
4979 BIF_ERROR(BIF_P, BADARG);
4980 }
4981 range = (Uint32) u;
4982 }
4983 hash = make_hash(BIF_ARG_1);
4984 if (range) {
4985 final_hash = 1 + (hash % range); /* [1..range] */
4986 } else if ((final_hash = hash + 1) == 0) {
4987 /*
4988 * XXX In this case, there will still be a ArithAlloc() in erts_mixed_plus().
4989 */
4990 BIF_RET(erts_mixed_plus(BIF_P,
4991 erts_make_integer(hash, BIF_P),
4992 make_small(1)));
4993 }
4994
4995 BIF_RET(erts_make_integer(final_hash, BIF_P));
4996 }
4997
phash2_1(BIF_ALIST_1)4998 BIF_RETTYPE phash2_1(BIF_ALIST_1)
4999 {
5000 Uint32 hash;
5001 Eterm trap_state = THE_NON_VALUE;
5002 hash = trapping_make_hash2(BIF_ARG_1, &trap_state, BIF_P);
5003 if (trap_state == THE_NON_VALUE) {
5004 BIF_RET(make_small(hash & ((1L << 27) - 1)));
5005 } else {
5006 BIF_TRAP1(&bif_trap_export[BIF_phash2_1], BIF_P, trap_state);
5007 }
5008 }
5009
phash2_2(BIF_ALIST_2)5010 BIF_RETTYPE phash2_2(BIF_ALIST_2)
5011 {
5012 Uint32 hash;
5013 Uint32 final_hash;
5014 Uint32 range;
5015 Eterm trap_state = THE_NON_VALUE;
5016
5017 /* Check for special case 2^32 */
5018 if (term_equals_2pow32(BIF_ARG_2)) {
5019 range = 0;
5020 } else {
5021 Uint u;
5022 if (!term_to_Uint(BIF_ARG_2, &u) || ((u >> 16) >> 16) != 0 || !u) {
5023 BIF_ERROR(BIF_P, BADARG);
5024 }
5025 range = (Uint32) u;
5026 }
5027 hash = trapping_make_hash2(BIF_ARG_1, &trap_state, BIF_P);
5028 if (trap_state != THE_NON_VALUE) {
5029 BIF_TRAP2(&bif_trap_export[BIF_phash2_2], BIF_P, trap_state, BIF_ARG_2);
5030 }
5031 if (range) {
5032 final_hash = hash % range; /* [0..range-1] */
5033 } else {
5034 final_hash = hash;
5035 }
5036 /*
5037 * Return either a small or a big. Use the heap for bigs if there is room.
5038 */
5039 #if defined(ARCH_64)
5040 BIF_RET(make_small(final_hash));
5041 #else
5042 if (IS_USMALL(0, final_hash)) {
5043 BIF_RET(make_small(final_hash));
5044 } else {
5045 Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE);
5046 BIF_RET(uint_to_big(final_hash, hp));
5047 }
5048 #endif
5049 }
5050
bump_reductions_1(BIF_ALIST_1)5051 BIF_RETTYPE bump_reductions_1(BIF_ALIST_1)
5052 {
5053 Sint reds;
5054
5055 if (is_not_small(BIF_ARG_1) || ((reds = signed_val(BIF_ARG_1)) < 0)) {
5056 BIF_ERROR(BIF_P, BADARG);
5057 }
5058
5059 if (reds > CONTEXT_REDS) {
5060 reds = CONTEXT_REDS;
5061 }
5062 BIF_RET2(am_true, reds);
5063 }
5064
erts_internal_cmp_term_2(BIF_ALIST_2)5065 BIF_RETTYPE erts_internal_cmp_term_2(BIF_ALIST_2) {
5066 Sint res = CMP_TERM(BIF_ARG_1,BIF_ARG_2);
5067
5068 /* ensure -1, 0, 1 result */
5069 if (res < 0) {
5070 BIF_RET(make_small(-1));
5071 } else if (res > 0) {
5072 BIF_RET(make_small(1));
5073 }
5074 BIF_RET(make_small(0));
5075 }
5076 /*
5077 * Processes doing yield on return in a bif ends up in bif_return_trap().
5078 */
bif_return_trap(BIF_ALIST_2)5079 static BIF_RETTYPE bif_return_trap(BIF_ALIST_2)
5080 {
5081 Eterm res = BIF_ARG_1;
5082
5083 switch (BIF_ARG_2) {
5084 case am_multi_scheduling: {
5085 int msb = erts_is_multi_scheduling_blocked();
5086 if (msb > 0)
5087 res = am_blocked;
5088 else if (msb < 0)
5089 res = am_blocked_normal;
5090 else
5091 ERTS_INTERNAL_ERROR("Unexpected multi scheduling block state");
5092 break;
5093 }
5094 default:
5095 break;
5096 }
5097 BIF_RET(res);
5098 }
5099
5100 static BIF_RETTYPE
bif_handle_signals_return(BIF_ALIST_1)5101 bif_handle_signals_return(BIF_ALIST_1)
5102 {
5103 int local_only = BIF_P->sig_qs.flags & FS_LOCAL_SIGS_ONLY;
5104 int sres, sreds, reds_left;
5105 erts_aint32_t state;
5106
5107 reds_left = ERTS_BIF_REDS_LEFT(BIF_P);
5108 sreds = reds_left;
5109
5110 if (!local_only) {
5111 erts_proc_lock(BIF_P, ERTS_PROC_LOCK_MSGQ);
5112 erts_proc_sig_fetch(BIF_P);
5113 erts_proc_unlock(BIF_P, ERTS_PROC_LOCK_MSGQ);
5114 }
5115
5116 state = erts_atomic32_read_nob(&BIF_P->state);
5117 sres = erts_proc_sig_handle_incoming(BIF_P, &state, &sreds,
5118 sreds, !0);
5119
5120 BUMP_REDS(BIF_P, (int) sreds);
5121 reds_left -= sreds;
5122
5123 if (state & ERTS_PSFLG_EXITING) {
5124 BIF_P->sig_qs.flags &= ~FS_LOCAL_SIGS_ONLY;
5125 ERTS_BIF_EXITED(BIF_P);
5126 }
5127 if (!sres | (reds_left <= 0)) {
5128 /*
5129 * More signals to handle or out of reds; need
5130 * to yield and continue. Prevent fetching of
5131 * more signals by setting local-sigs-only flag.
5132 */
5133 BIF_P->sig_qs.flags |= FS_LOCAL_SIGS_ONLY;
5134 ERTS_BIF_YIELD1(&erts_bif_handle_signals_return_export,
5135 BIF_P, BIF_ARG_1);
5136 }
5137
5138 BIF_P->sig_qs.flags &= ~FS_LOCAL_SIGS_ONLY;
5139 BIF_RET(BIF_ARG_1);
5140 }
5141
5142 Export bif_return_trap_export;
5143 Export erts_bif_handle_signals_return_export;
5144
erts_init_trap_export(Export * ep,Eterm m,Eterm f,Uint a,Eterm (* bif)(BIF_ALIST))5145 void erts_init_trap_export(Export* ep, Eterm m, Eterm f, Uint a,
5146 Eterm (*bif)(BIF_ALIST))
5147 {
5148 int i;
5149
5150 sys_memset((void *) ep, 0, sizeof(Export));
5151
5152 for (i=0; i<ERTS_NUM_CODE_IX; i++) {
5153 ep->addressv[i] = ep->trampoline.raw;
5154 }
5155
5156 ep->bif_number = -1;
5157
5158 ep->info.op = op_i_func_info_IaaI;
5159 ep->info.mfa.module = m;
5160 ep->info.mfa.function = f;
5161 ep->info.mfa.arity = a;
5162
5163 ep->trampoline.op = BeamOpCodeAddr(op_call_bif_W);
5164 ep->trampoline.raw[1] = (BeamInstr)bif;
5165 }
5166
5167 /*
5168 * Writes a BIF call wrapper to the given address.
5169 */
erts_write_bif_wrapper(Export * export,BeamInstr * address)5170 void erts_write_bif_wrapper(Export *export, BeamInstr *address) {
5171 BifEntry *entry = &bif_table[export->bif_number];
5172
5173 address[0] = BeamOpCodeAddr(op_call_bif_W);
5174 address[1] = (BeamInstr)entry->f;
5175 }
5176
erts_init_bif(void)5177 void erts_init_bif(void)
5178 {
5179 /*
5180 * bif_return_trap/2 is a hidden BIF that bifs that need to
5181 * yield the calling process traps to.
5182 */
5183 erts_init_trap_export(&bif_return_trap_export,
5184 am_erlang, am_bif_return_trap, 2,
5185 &bif_return_trap);
5186
5187 erts_init_trap_export(&erts_bif_handle_signals_return_export,
5188 am_erlang, am_bif_handle_signals_return, 1,
5189 &bif_handle_signals_return);
5190
5191 erts_await_result = erts_export_put(am_erts_internal,
5192 am_await_result,
5193 1);
5194
5195 erts_init_trap_export(&dsend_continue_trap_export,
5196 am_erts_internal, am_dsend_continue_trap, 1,
5197 dsend_continue_trap_1);
5198
5199 erts_init_trap_export(&await_exit_trap, am_erts_internal,
5200 am_await_exit, 0, erts_internal_await_exit_trap);
5201
5202 flush_monitor_messages_trap = erts_export_put(am_erts_internal,
5203 am_flush_monitor_messages,
5204 3);
5205
5206 erts_convert_time_unit_trap = erts_export_put(am_erlang,
5207 am_convert_time_unit,
5208 3);
5209
5210 set_cpu_topology_trap = erts_export_put(am_erlang,
5211 am_set_cpu_topology,
5212 1);
5213 erts_format_cpu_topology_trap = erts_export_put(am_erlang,
5214 am_format_cpu_topology,
5215 1);
5216 await_port_send_result_trap
5217 = erts_export_put(am_erts_internal, am_await_port_send_result, 3);
5218 system_flag_scheduler_wall_time_trap
5219 = erts_export_put(am_erts_internal, am_system_flag_scheduler_wall_time, 1);
5220 await_sched_wall_time_mod_trap
5221 = erts_export_put(am_erts_internal, am_await_sched_wall_time_modifications, 2);
5222 await_msacc_mod_trap
5223 = erts_export_put(am_erts_internal, am_await_microstate_accounting_modifications, 3);
5224
5225 erts_atomic32_init_nob(&sched_wall_time, 0);
5226 erts_atomic32_init_nob(&msacc, ERTS_MSACC_IS_ENABLED());
5227 }
5228
5229 /*
5230 * Scheduling of BIFs via ErtsNativeFunc...
5231 */
5232 #define ERTS_WANT_NFUNC_SCHED_INTERNALS__
5233 #include "erl_nfunc_sched.h"
5234
5235 #define ERTS_SCHED_BIF_TRAP_MARKER ((void *) (UWord) 1)
5236
5237 static ERTS_INLINE void
schedule(Process * c_p,Process * dirty_shadow_proc,ErtsCodeMFA * mfa,BeamInstr * pc,ErtsBifFunc dfunc,void * ifunc,Eterm module,Eterm function,int argc,Eterm * argv)5238 schedule(Process *c_p, Process *dirty_shadow_proc,
5239 ErtsCodeMFA *mfa, BeamInstr *pc,
5240 ErtsBifFunc dfunc, void *ifunc,
5241 Eterm module, Eterm function,
5242 int argc, Eterm *argv)
5243 {
5244 ERTS_LC_ASSERT(ERTS_PROC_LOCK_MAIN & erts_proc_lc_my_proc_locks(c_p));
5245 (void) erts_nfunc_schedule(c_p, dirty_shadow_proc,
5246 mfa, pc, BeamOpCodeAddr(op_call_bif_W),
5247 dfunc, ifunc,
5248 module, function,
5249 argc, argv);
5250 }
5251
5252
dirty_bif_result(BIF_ALIST_1)5253 static BIF_RETTYPE dirty_bif_result(BIF_ALIST_1)
5254 {
5255 ErtsNativeFunc *nep = (ErtsNativeFunc *) ERTS_PROC_GET_NFUNC_TRAP_WRAPPER(BIF_P);
5256 erts_nfunc_restore(BIF_P, nep, BIF_ARG_1);
5257 BIF_RET(BIF_ARG_1);
5258 }
5259
dirty_bif_trap(BIF_ALIST)5260 static BIF_RETTYPE dirty_bif_trap(BIF_ALIST)
5261 {
5262 ErtsNativeFunc *nep = (ErtsNativeFunc *) ERTS_PROC_GET_NFUNC_TRAP_WRAPPER(BIF_P);
5263
5264 /*
5265 * Arity and argument registers already set
5266 * correct by call to dirty_bif_trap()...
5267 */
5268
5269 ASSERT(BIF_P->arity == nep->trampoline.info.mfa.arity);
5270
5271 erts_nfunc_restore(BIF_P, nep, THE_NON_VALUE);
5272
5273 BIF_P->i = (BeamInstr *) nep->func;
5274 BIF_P->freason = TRAP;
5275 return THE_NON_VALUE;
5276 }
5277
dirty_bif_exception(BIF_ALIST_2)5278 static BIF_RETTYPE dirty_bif_exception(BIF_ALIST_2)
5279 {
5280 Eterm freason;
5281
5282 ASSERT(is_small(BIF_ARG_1));
5283
5284 freason = signed_val(BIF_ARG_1);
5285
5286 /* Restore orig info for error and clear nif wrapper in handle_error() */
5287 freason |= EXF_RESTORE_NFUNC;
5288
5289 BIF_P->fvalue = BIF_ARG_2;
5290
5291 BIF_ERROR(BIF_P, freason);
5292 }
5293
5294
5295 static BIF_RETTYPE call_bif(Process *c_p, Eterm *reg, BeamInstr *I);
5296
5297 BIF_RETTYPE
erts_schedule_bif(Process * proc,Eterm * argv,BeamInstr * i,ErtsBifFunc bif,ErtsSchedType sched_type,Eterm mod,Eterm func,int argc)5298 erts_schedule_bif(Process *proc,
5299 Eterm *argv,
5300 BeamInstr *i,
5301 ErtsBifFunc bif,
5302 ErtsSchedType sched_type,
5303 Eterm mod,
5304 Eterm func,
5305 int argc)
5306 {
5307 Process *c_p, *dirty_shadow_proc;
5308 ErtsCodeMFA *mfa;
5309
5310 if (proc->static_flags & ERTS_STC_FLG_SHADOW_PROC) {
5311 dirty_shadow_proc = proc;
5312 c_p = proc->next;
5313 ASSERT(c_p->common.id == dirty_shadow_proc->common.id);
5314 erts_proc_lock(c_p, ERTS_PROC_LOCK_MAIN);
5315 }
5316 else
5317 {
5318 dirty_shadow_proc = NULL;
5319 c_p = proc;
5320 }
5321
5322 if (!ERTS_PROC_IS_EXITING(c_p)) {
5323 Export *exp;
5324 BifFunction dbif, ibif;
5325 BeamInstr call_instr;
5326 BeamInstr *pc;
5327
5328 /*
5329 * dbif - direct bif
5330 * ibif - indirect bif
5331 */
5332
5333 erts_aint32_t set, mask;
5334 mask = (ERTS_PSFLG_DIRTY_CPU_PROC
5335 | ERTS_PSFLG_DIRTY_IO_PROC);
5336 switch (sched_type) {
5337 case ERTS_SCHED_DIRTY_CPU:
5338 set = ERTS_PSFLG_DIRTY_CPU_PROC;
5339 dbif = bif;
5340 ibif = NULL;
5341 break;
5342 case ERTS_SCHED_DIRTY_IO:
5343 set = ERTS_PSFLG_DIRTY_IO_PROC;
5344 dbif = bif;
5345 ibif = NULL;
5346 break;
5347 case ERTS_SCHED_NORMAL:
5348 default:
5349 set = 0;
5350 dbif = call_bif;
5351 ibif = bif;
5352 break;
5353 }
5354
5355 (void) erts_atomic32_read_bset_nob(&c_p->state, mask, set);
5356
5357 if (i == NULL) {
5358 ERTS_INTERNAL_ERROR("Missing instruction pointer");
5359 }
5360
5361 if (BeamIsOpCode(*i, op_i_generic_breakpoint)) {
5362 ErtsCodeInfo *ci;
5363 GenericBp *bp;
5364
5365 ci = erts_code_to_codeinfo(i);
5366 bp = ci->u.gen_bp;
5367
5368 call_instr = bp->orig_instr;
5369 } else {
5370 call_instr = *i;
5371 }
5372
5373 #ifdef HIPE
5374 if (proc->flags & F_HIPE_MODE) {
5375 /* Pointer to bif export in i */
5376 exp = (Export *) i;
5377 pc = cp_val(c_p->stop[0]);
5378 mfa = &exp->info.mfa;
5379 } else /* !! This is part of the if clause below !! */
5380 #endif
5381 if (BeamIsOpCode(call_instr, op_call_light_bif_be)) {
5382 /* Pointer to bif export in i+2 */
5383 exp = (Export *) i[2];
5384 pc = i;
5385 mfa = &exp->info.mfa;
5386 }
5387 else if (BeamIsOpCode(call_instr, op_call_light_bif_only_be)) {
5388 /* Pointer to bif export in i+2 */
5389 exp = (Export *) i[2];
5390 pc = i;
5391 mfa = &exp->info.mfa;
5392 }
5393 else if (BeamIsOpCode(call_instr, op_call_bif_W)) {
5394 pc = cp_val(c_p->stop[0]);
5395 mfa = erts_code_to_codemfa(i);
5396 }
5397 else {
5398 ERTS_INTERNAL_ERROR("erts_schedule_bif() called "
5399 "from unexpected instruction");
5400 }
5401 ASSERT(bif);
5402
5403 if (argc < 0) { /* reschedule original call */
5404 mod = mfa->module;
5405 func = mfa->function;
5406 argc = (int) mfa->arity;
5407 }
5408
5409 schedule(c_p, dirty_shadow_proc, mfa, pc, dbif, ibif,
5410 mod, func, argc, argv);
5411 }
5412
5413 if (dirty_shadow_proc)
5414 erts_proc_unlock(c_p, ERTS_PROC_LOCK_MAIN);
5415
5416 return THE_NON_VALUE;
5417 }
5418
5419 static BIF_RETTYPE
call_bif(Process * c_p,Eterm * reg,BeamInstr * I)5420 call_bif(Process *c_p, Eterm *reg, BeamInstr *I)
5421 {
5422 ErtsNativeFunc *nep = ERTS_I_BEAM_OP_TO_NFUNC(I);
5423 ErtsBifFunc bif = (ErtsBifFunc) nep->func;
5424 BIF_RETTYPE ret;
5425
5426 ASSERT(!ERTS_SCHEDULER_IS_DIRTY(erts_get_scheduler_data()));
5427
5428 nep->func = ERTS_SCHED_BIF_TRAP_MARKER;
5429
5430 ASSERT(bif);
5431
5432 ret = (*bif)(c_p, reg, I);
5433
5434 if (is_value(ret))
5435 erts_nfunc_restore(c_p, nep, ret);
5436 else if (c_p->freason != TRAP)
5437 c_p->freason |= EXF_RESTORE_NFUNC; /* restore in handle_error() */
5438 else if (nep->func == ERTS_SCHED_BIF_TRAP_MARKER) {
5439 /* BIF did an ordinary trap... */
5440 erts_nfunc_restore(c_p, nep, ret);
5441 }
5442 /* else:
5443 * BIF rescheduled itself using erts_schedule_bif().
5444 */
5445
5446 return ret;
5447 }
5448
5449
5450 int
erts_call_dirty_bif(ErtsSchedulerData * esdp,Process * c_p,BeamInstr * I,Eterm * reg)5451 erts_call_dirty_bif(ErtsSchedulerData *esdp, Process *c_p, BeamInstr *I, Eterm *reg)
5452 {
5453 BIF_RETTYPE result;
5454 int exiting;
5455 Process *dirty_shadow_proc;
5456 ErtsBifFunc bf;
5457 ErtsNativeFunc *nep;
5458 #ifdef DEBUG
5459 Eterm *c_p_htop;
5460 erts_aint32_t state;
5461
5462 ASSERT(!c_p->scheduler_data);
5463 state = erts_atomic32_read_nob(&c_p->state);
5464 ASSERT((state & ERTS_PSFLG_DIRTY_RUNNING)
5465 && !(state & (ERTS_PSFLG_RUNNING|ERTS_PSFLG_RUNNING_SYS)));
5466 ASSERT(esdp);
5467
5468 #endif
5469
5470 nep = ERTS_I_BEAM_OP_TO_NFUNC(I);
5471 ASSERT(nep == ERTS_PROC_GET_NFUNC_TRAP_WRAPPER(c_p));
5472
5473 nep->func = ERTS_SCHED_BIF_TRAP_MARKER;
5474
5475 bf = (ErtsBifFunc) I[1];
5476
5477 erts_atomic32_read_band_mb(&c_p->state, ~(ERTS_PSFLG_DIRTY_CPU_PROC
5478 | ERTS_PSFLG_DIRTY_IO_PROC));
5479
5480 dirty_shadow_proc = erts_make_dirty_shadow_proc(esdp, c_p);
5481
5482 dirty_shadow_proc->freason = c_p->freason;
5483 dirty_shadow_proc->fvalue = c_p->fvalue;
5484 dirty_shadow_proc->ftrace = c_p->ftrace;
5485 dirty_shadow_proc->i = c_p->i;
5486
5487 #ifdef DEBUG
5488 c_p_htop = c_p->htop;
5489 #endif
5490
5491 erts_proc_unlock(c_p, ERTS_PROC_LOCK_MAIN);
5492
5493 result = (*bf)(dirty_shadow_proc, reg, I);
5494
5495 erts_proc_lock(c_p, ERTS_PROC_LOCK_MAIN);
5496
5497 ASSERT(c_p_htop == c_p->htop);
5498 ASSERT(dirty_shadow_proc->static_flags & ERTS_STC_FLG_SHADOW_PROC);
5499 ASSERT(dirty_shadow_proc->next == c_p);
5500
5501 exiting = ERTS_PROC_IS_EXITING(c_p);
5502
5503 if (!exiting) {
5504 if (is_value(result))
5505 schedule(c_p, dirty_shadow_proc, NULL, NULL, dirty_bif_result,
5506 NULL, am_erts_internal, am_dirty_bif_result, 1, &result);
5507 else if (dirty_shadow_proc->freason != TRAP) {
5508 Eterm argv[2];
5509 ASSERT(dirty_shadow_proc->freason <= MAX_SMALL);
5510 argv[0] = make_small(dirty_shadow_proc->freason);
5511 argv[1] = dirty_shadow_proc->fvalue;
5512 schedule(c_p, dirty_shadow_proc, NULL, NULL,
5513 dirty_bif_exception, NULL, am_erts_internal,
5514 am_dirty_bif_exception, 2, argv);
5515 }
5516 else if (nep->func == ERTS_SCHED_BIF_TRAP_MARKER) {
5517 /* Dirty BIF did an ordinary trap... */
5518 ASSERT(!(erts_atomic32_read_nob(&c_p->state)
5519 & (ERTS_PSFLG_DIRTY_CPU_PROC|ERTS_PSFLG_DIRTY_IO_PROC)));
5520 schedule(c_p, dirty_shadow_proc, NULL, NULL,
5521 dirty_bif_trap, (void *) dirty_shadow_proc->i,
5522 am_erts_internal, am_dirty_bif_trap,
5523 dirty_shadow_proc->arity, reg);
5524 }
5525 /* else:
5526 * BIF rescheduled itself using erts_schedule_bif().
5527 */
5528 c_p->freason = dirty_shadow_proc->freason;
5529 c_p->fvalue = dirty_shadow_proc->fvalue;
5530 c_p->ftrace = dirty_shadow_proc->ftrace;
5531 c_p->i = dirty_shadow_proc->i;
5532 c_p->arity = dirty_shadow_proc->arity;
5533 }
5534
5535 erts_flush_dirty_shadow_proc(dirty_shadow_proc);
5536
5537 return exiting;
5538 }
5539
get_module_info_1(BIF_ALIST_1)5540 BIF_RETTYPE get_module_info_1(BIF_ALIST_1)
5541 {
5542 Eterm ret = erts_module_info_0(BIF_P, BIF_ARG_1);
5543
5544 if (is_non_value(ret)) {
5545 BIF_ERROR(BIF_P, BADARG);
5546 }
5547 BIF_RET(ret);
5548 }
5549
5550
get_module_info_2(BIF_ALIST_2)5551 BIF_RETTYPE get_module_info_2(BIF_ALIST_2)
5552 {
5553 Eterm ret = erts_module_info_1(BIF_P, BIF_ARG_1, BIF_ARG_2);
5554
5555 if (is_non_value(ret)) {
5556 BIF_ERROR(BIF_P, BADARG);
5557 }
5558 BIF_RET(ret);
5559 }
5560
dt_put_tag_1(BIF_ALIST_1)5561 BIF_RETTYPE dt_put_tag_1(BIF_ALIST_1)
5562 {
5563 #ifdef USE_VM_PROBES
5564 Eterm otag;
5565 if (BIF_ARG_1 == am_undefined) {
5566 otag = (DT_UTAG(BIF_P) == NIL) ? am_undefined : DT_UTAG(BIF_P);
5567 DT_UTAG(BIF_P) = NIL;
5568 DT_UTAG_FLAGS(BIF_P) = 0;
5569 if (SEQ_TRACE_TOKEN(BIF_P) == am_have_dt_utag) {
5570 SEQ_TRACE_TOKEN(BIF_P) = NIL;
5571 }
5572 BIF_RET(otag);
5573 }
5574 if (!is_binary(BIF_ARG_1)) {
5575 BIF_ERROR(BIF_P,BADARG);
5576 }
5577 otag = (DT_UTAG(BIF_P) == NIL) ? am_undefined : DT_UTAG(BIF_P);
5578 DT_UTAG(BIF_P) = BIF_ARG_1;
5579 DT_UTAG_FLAGS(BIF_P) |= DT_UTAG_PERMANENT;
5580 if (SEQ_TRACE_TOKEN(BIF_P) == NIL) {
5581 SEQ_TRACE_TOKEN(BIF_P) = am_have_dt_utag;
5582 }
5583 BIF_RET(otag);
5584 #else
5585 BIF_RET(am_undefined);
5586 #endif
5587 }
5588
dt_get_tag_0(BIF_ALIST_0)5589 BIF_RETTYPE dt_get_tag_0(BIF_ALIST_0)
5590 {
5591 #ifdef USE_VM_PROBES
5592 BIF_RET((DT_UTAG(BIF_P) == NIL || !(DT_UTAG_FLAGS(BIF_P) & DT_UTAG_PERMANENT)) ? am_undefined : DT_UTAG(BIF_P));
5593 #else
5594 BIF_RET(am_undefined);
5595 #endif
5596 }
dt_get_tag_data_0(BIF_ALIST_0)5597 BIF_RETTYPE dt_get_tag_data_0(BIF_ALIST_0)
5598 {
5599 #ifdef USE_VM_PROBES
5600 BIF_RET((DT_UTAG(BIF_P) == NIL) ? am_undefined : DT_UTAG(BIF_P));
5601 #else
5602 BIF_RET(am_undefined);
5603 #endif
5604 }
dt_prepend_vm_tag_data_1(BIF_ALIST_1)5605 BIF_RETTYPE dt_prepend_vm_tag_data_1(BIF_ALIST_1)
5606 {
5607 #ifdef USE_VM_PROBES
5608 Eterm b;
5609 Eterm *hp;
5610 if (is_binary((DT_UTAG(BIF_P)))) {
5611 Uint sz = binary_size(DT_UTAG(BIF_P));
5612 int i;
5613 unsigned char *p,*q;
5614 byte *temp_alloc = NULL;
5615 b = new_binary(BIF_P,NULL,sz+1);
5616 q = binary_bytes(b);
5617 p = erts_get_aligned_binary_bytes(DT_UTAG(BIF_P),&temp_alloc);
5618 for(i=0;i<sz;++i) {
5619 q[i] = p[i];
5620 }
5621 erts_free_aligned_binary_bytes(temp_alloc);
5622 q[sz] = '\0';
5623 } else {
5624 b = new_binary(BIF_P,(byte *)"\0",1);
5625 }
5626 hp = HAlloc(BIF_P,2);
5627 BIF_RET(CONS(hp,b,BIF_ARG_1));
5628 #else
5629 BIF_RET(BIF_ARG_1);
5630 #endif
5631 }
dt_append_vm_tag_data_1(BIF_ALIST_1)5632 BIF_RETTYPE dt_append_vm_tag_data_1(BIF_ALIST_1)
5633 {
5634 #ifdef USE_VM_PROBES
5635 Eterm b;
5636 Eterm *hp;
5637 if (is_binary((DT_UTAG(BIF_P)))) {
5638 Uint sz = binary_size(DT_UTAG(BIF_P));
5639 int i;
5640 unsigned char *p,*q;
5641 byte *temp_alloc = NULL;
5642 b = new_binary(BIF_P,NULL,sz+1);
5643 q = binary_bytes(b);
5644 p = erts_get_aligned_binary_bytes(DT_UTAG(BIF_P),&temp_alloc);
5645 for(i=0;i<sz;++i) {
5646 q[i] = p[i];
5647 }
5648 erts_free_aligned_binary_bytes(temp_alloc);
5649 q[sz] = '\0';
5650 } else {
5651 b = new_binary(BIF_P,(byte *)"\0",1);
5652 }
5653 hp = HAlloc(BIF_P,2);
5654 BIF_RET(CONS(hp,BIF_ARG_1,b));
5655 #else
5656 BIF_RET(BIF_ARG_1);
5657 #endif
5658 }
dt_spread_tag_1(BIF_ALIST_1)5659 BIF_RETTYPE dt_spread_tag_1(BIF_ALIST_1)
5660 {
5661 #ifdef USE_VM_PROBES
5662 Eterm ret;
5663 Eterm *hp;
5664 #endif
5665 if (BIF_ARG_1 != am_true && BIF_ARG_1 != am_false) {
5666 BIF_ERROR(BIF_P,BADARG);
5667 }
5668 #ifdef USE_VM_PROBES
5669 hp = HAlloc(BIF_P,3);
5670 ret = TUPLE2(hp,make_small(DT_UTAG_FLAGS(BIF_P)),DT_UTAG(BIF_P));
5671 if (DT_UTAG(BIF_P) != NIL) {
5672 if (BIF_ARG_1 == am_true) {
5673 DT_UTAG_FLAGS(BIF_P) |= DT_UTAG_SPREADING;
5674 #ifdef DTRACE_TAG_HARDDEBUG
5675 erts_fprintf(stderr,
5676 "Dtrace -> (%T) start spreading tag %T\r\n",
5677 BIF_P->common.id,DT_UTAG(BIF_P));
5678 #endif
5679 } else {
5680 DT_UTAG_FLAGS(BIF_P) &= ~DT_UTAG_SPREADING;
5681 #ifdef DTRACE_TAG_HARDDEBUG
5682 erts_fprintf(stderr,
5683 "Dtrace -> (%T) stop spreading tag %T\r\n",
5684 BIF_P->common.id,DT_UTAG(BIF_P));
5685 #endif
5686 }
5687 }
5688 BIF_RET(ret);
5689 #else
5690 BIF_RET(am_true);
5691 #endif
5692 }
dt_restore_tag_1(BIF_ALIST_1)5693 BIF_RETTYPE dt_restore_tag_1(BIF_ALIST_1)
5694 {
5695 #ifdef USE_VM_PROBES
5696 Eterm *tpl;
5697 Uint x;
5698 if (is_not_tuple(BIF_ARG_1)) {
5699 BIF_ERROR(BIF_P,BADARG);
5700 }
5701 tpl = tuple_val(BIF_ARG_1);
5702 if(arityval(*tpl) != 2 || is_not_small(tpl[1]) || (is_not_binary(tpl[2]) && tpl[2] != NIL)) {
5703 BIF_ERROR(BIF_P,BADARG);
5704 }
5705 if (tpl[2] == NIL) {
5706 if (DT_UTAG(BIF_P) != NIL) {
5707 #ifdef DTRACE_TAG_HARDDEBUG
5708 erts_fprintf(stderr,
5709 "Dtrace -> (%T) restore Killing tag!\r\n",
5710 BIF_P->common.id);
5711 #endif
5712 }
5713 DT_UTAG(BIF_P) = NIL;
5714 if (SEQ_TRACE_TOKEN(BIF_P) == am_have_dt_utag) {
5715 SEQ_TRACE_TOKEN(BIF_P) = NIL;
5716 }
5717 DT_UTAG_FLAGS(BIF_P) = 0;
5718 } else {
5719 x = unsigned_val(tpl[1]) & (DT_UTAG_SPREADING | DT_UTAG_PERMANENT);
5720 #ifdef DTRACE_TAG_HARDDEBUG
5721
5722 if (!(x & DT_UTAG_SPREADING) && (DT_UTAG_FLAGS(BIF_P) &
5723 DT_UTAG_SPREADING)) {
5724 erts_fprintf(stderr,
5725 "Dtrace -> (%T) restore stop spreading "
5726 "tag %T\r\n",
5727 BIF_P->common.id, tpl[2]);
5728 } else if ((x & DT_UTAG_SPREADING) &&
5729 !(DT_UTAG_FLAGS(BIF_P) & DT_UTAG_SPREADING)) {
5730 erts_fprintf(stderr,
5731 "Dtrace -> (%T) restore start spreading "
5732 "tag %T\r\n",BIF_P->common.id,tpl[2]);
5733 }
5734 #endif
5735 DT_UTAG_FLAGS(BIF_P) = x;
5736 DT_UTAG(BIF_P) = tpl[2];
5737 if (SEQ_TRACE_TOKEN(BIF_P) == NIL) {
5738 SEQ_TRACE_TOKEN(BIF_P) = am_have_dt_utag;
5739 }
5740 }
5741 #else
5742 if (BIF_ARG_1 != am_true) {
5743 BIF_ERROR(BIF_P,BADARG);
5744 }
5745 #endif
5746 BIF_RET(am_true);
5747 }
5748