The R13B03 release.OTP_R13B03

1 files changed, 628 insertions, 0 deletions

diff --git a/erts/emulator/beam/erl_bif_guard.c b/erts/emulator/beam/erl_bif_guard.c
new file mode 100644
index 0000000000..8b47db10dd
--- /dev/null
+++ b/erts/emulator/beam/erl_bif_guard.c
@@ -0,0 +1,628 @@
+/*
+ * %CopyrightBegin%
+ * 
+ * Copyright Ericsson AB 2006-2009. All Rights Reserved.
+ * 
+ * The contents of this file are subject to the Erlang Public License,
+ * Version 1.1, (the "License"); you may not use this file except in
+ * compliance with the License. You should have received a copy of the
+ * Erlang Public License along with this software. If not, it can be
+ * retrieved online at http://www.erlang.org/.
+ * 
+ * Software distributed under the License is distributed on an "AS IS"
+ * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+ * the License for the specific language governing rights and limitations
+ * under the License.
+ * 
+ * %CopyrightEnd%
+ */
+
+/*
+ * Numeric guard BIFs.
+ */
+
+#ifdef HAVE_CONFIG_H
+#  include "config.h"
+#endif
+
+#include "sys.h"
+#include "erl_vm.h"
+#include "global.h"
+#include "erl_process.h"
+#include "error.h"
+#include "bif.h"
+#include "big.h"
+#include "erl_binary.h"
+
+static Eterm gc_double_to_integer(Process* p, double x, Eterm* reg, Uint live);
+
+static Eterm double_to_integer(Process* p, double x);
+
+/*
+ * Guard BIFs called using apply/3 and guard BIFs that never build
+ * anything on the heap.
+ */
+
+BIF_RETTYPE abs_1(BIF_ALIST_1)
+{
+    Eterm res;
+    Sint i0, i;
+    Eterm* hp;
+
+    /* integer arguments */
+    if (is_small(BIF_ARG_1)) {
+	i0 = signed_val(BIF_ARG_1);
+	i = labs(i0);
+	if (i0 == MIN_SMALL) {
+	    hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE);
+	    BIF_RET(uint_to_big(i, hp));
+	} else {
+	    BIF_RET(make_small(i));
+	}
+    } else if (is_big(BIF_ARG_1)) {
+	if (!big_sign(BIF_ARG_1)) {
+	    BIF_RET(BIF_ARG_1);
+	} else {
+	    int sz = big_arity(BIF_ARG_1) + 1;
+	    Uint* x;
+
+	    hp = HAlloc(BIF_P, sz);	/* See note at beginning of file */
+	    sz--;
+	    res = make_big(hp);
+	    x = big_val(BIF_ARG_1);
+	    *hp++ = make_pos_bignum_header(sz);
+	    x++;                          /* skip thing */
+	    while(sz--)
+		*hp++ = *x++;
+	    BIF_RET(res);
+	}
+    } else if (is_float(BIF_ARG_1)) {
+	FloatDef f;
+
+	GET_DOUBLE(BIF_ARG_1, f);
+	if (f.fd < 0.0) {
+	    hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT);
+	    f.fd = fabs(f.fd);
+	    res = make_float(hp);
+	    PUT_DOUBLE(f, hp);
+	    BIF_RET(res);
+	}
+	else
+	    BIF_RET(BIF_ARG_1);
+    }
+    BIF_ERROR(BIF_P, BADARG);
+}
+
+BIF_RETTYPE float_1(BIF_ALIST_1)
+{
+    Eterm res;
+    Eterm* hp;
+    FloatDef f;
+     
+    /* check args */
+    if (is_not_integer(BIF_ARG_1)) {
+	if (is_float(BIF_ARG_1))  {
+	    BIF_RET(BIF_ARG_1);
+	} else {
+	badarg:
+	    BIF_ERROR(BIF_P, BADARG);
+	}
+    }
+    if (is_small(BIF_ARG_1)) {
+	Sint i = signed_val(BIF_ARG_1);
+	f.fd = i;		/* use "C"'s auto casting */
+    } else if (big_to_double(BIF_ARG_1, &f.fd) < 0) {
+	goto badarg;
+    }
+    hp = HAlloc(BIF_P, FLOAT_SIZE_OBJECT);
+    res = make_float(hp);
+    PUT_DOUBLE(f, hp);
+    BIF_RET(res);
+}
+
+BIF_RETTYPE trunc_1(BIF_ALIST_1)
+{
+    Eterm res;
+    FloatDef f;
+     
+    /* check arg */
+    if (is_not_float(BIF_ARG_1)) {
+	if (is_integer(BIF_ARG_1)) 
+	    BIF_RET(BIF_ARG_1);
+	BIF_ERROR(BIF_P, BADARG);
+    }
+    /* get the float */
+    GET_DOUBLE(BIF_ARG_1, f);
+
+    /* truncate it and return the resultant integer */
+    res = double_to_integer(BIF_P, (f.fd >= 0.0) ? floor(f.fd) : ceil(f.fd));
+    BIF_RET(res);
+}
+
+BIF_RETTYPE round_1(BIF_ALIST_1)
+{
+    Eterm res;
+    FloatDef f;
+     
+    /* check arg */ 
+    if (is_not_float(BIF_ARG_1)) {
+	if (is_integer(BIF_ARG_1)) 
+	    BIF_RET(BIF_ARG_1);
+	BIF_ERROR(BIF_P, BADARG);
+    }
+     
+    /* get the float */
+    GET_DOUBLE(BIF_ARG_1, f);
+
+    /* round it and return the resultant integer */
+    res = double_to_integer(BIF_P, (f.fd > 0.0) ? f.fd + 0.5 : f.fd - 0.5);
+    BIF_RET(res);
+}
+
+BIF_RETTYPE length_1(BIF_ALIST_1)
+{
+    Eterm list;
+    Uint i;
+     
+    if (is_nil(BIF_ARG_1)) 
+	BIF_RET(SMALL_ZERO);
+    if (is_not_list(BIF_ARG_1)) {
+	BIF_ERROR(BIF_P, BADARG);
+    }
+    list = BIF_ARG_1;
+    i = 0;
+    while (is_list(list)) {
+	i++;
+	list = CDR(list_val(list));
+    }
+    if (is_not_nil(list))  {
+	BIF_ERROR(BIF_P, BADARG);
+    }
+    BIF_RET(make_small(i));
+}
+
+/* returns the size of a tuple or a binary */
+
+BIF_RETTYPE size_1(BIF_ALIST_1)
+{
+    if (is_tuple(BIF_ARG_1)) {
+	Eterm* tupleptr = tuple_val(BIF_ARG_1);
+
+	BIF_RET(make_small(arityval(*tupleptr)));
+    } else if (is_binary(BIF_ARG_1)) {
+	Uint sz = binary_size(BIF_ARG_1);
+	if (IS_USMALL(0, sz)) {
+	    return make_small(sz);
+	} else {
+	    Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE);
+	    BIF_RET(uint_to_big(sz, hp));
+	}
+    }
+    BIF_ERROR(BIF_P, BADARG);
+}
+
+/**********************************************************************/
+/* returns the bitsize of a bitstring */
+
+BIF_RETTYPE bit_size_1(BIF_ALIST_1)
+{
+    Uint low_bits;
+    Uint bytesize;
+    Uint high_bits;
+    if (is_binary(BIF_ARG_1)) {
+	bytesize = binary_size(BIF_ARG_1);
+	high_bits = bytesize >>  ((sizeof(Uint) * 8)-3);
+	low_bits = (bytesize << 3) + binary_bitsize(BIF_ARG_1);
+	if (high_bits == 0) {
+	    if (IS_USMALL(0,low_bits)) {
+		BIF_RET(make_small(low_bits));
+	    } else {
+		Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE);
+		BIF_RET(uint_to_big(low_bits, hp));
+	    }
+	} else {
+	    Uint sz = BIG_UINT_HEAP_SIZE+1;
+	    Eterm* hp = HAlloc(BIF_P, sz);
+	    hp[0] = make_pos_bignum_header(sz-1);
+	    BIG_DIGIT(hp,0) = low_bits;
+	    BIG_DIGIT(hp,1) = high_bits;
+	    BIF_RET(make_big(hp));
+	}
+    } else {
+	BIF_ERROR(BIF_P, BADARG);
+    }
+}
+
+/**********************************************************************/
+/* returns the number of bytes need to store a bitstring */
+
+BIF_RETTYPE byte_size_1(BIF_ALIST_1)
+{
+    if (is_binary(BIF_ARG_1)) {
+	Uint bytesize = binary_size(BIF_ARG_1);
+	if (binary_bitsize(BIF_ARG_1) > 0) {
+	    bytesize++;
+	}
+	if (IS_USMALL(0, bytesize)) {
+	    BIF_RET(make_small(bytesize));
+	} else {
+	    Eterm* hp = HAlloc(BIF_P, BIG_UINT_HEAP_SIZE);
+	    BIF_RET(uint_to_big(bytesize, hp));
+	}
+    } else {
+	BIF_ERROR(BIF_P, BADARG);
+    }
+}
+
+/*
+ * Generate the integer part from a double.
+ */
+static Eterm
+double_to_integer(Process* p, double x)
+{
+    int is_negative;
+    int ds;
+    ErtsDigit* xp;
+    int i;
+    Eterm res;
+    size_t sz;
+    Eterm* hp;
+    double dbase;
+
+    if ((x < (double) (MAX_SMALL+1)) && (x > (double) (MIN_SMALL-1))) {
+	Sint xi = x;
+	return make_small(xi);
+    }
+
+    if (x >= 0) {
+	is_negative = 0;
+    } else {
+	is_negative = 1;
+	x = -x;
+    }
+
+    /* Unscale & (calculate exponent) */
+    ds = 0;
+    dbase = ((double)(D_MASK)+1);
+    while(x >= 1.0) {
+	x /= dbase;         /* "shift" right */
+	ds++;
+    }
+    sz = BIG_NEED_SIZE(ds);          /* number of words including arity */
+
+    hp = HAlloc(p, sz);
+    res = make_big(hp);
+    xp = (ErtsDigit*) (hp + 1);
+
+    for (i = ds-1; i >= 0; i--) {
+	ErtsDigit d;
+
+	x *= dbase;      /* "shift" left */
+	d = x;            /* trunc */
+	xp[i] = d;        /* store digit */
+	x -= d;           /* remove integer part */
+    }
+    while ((ds & (BIG_DIGITS_PER_WORD-1)) != 0) {
+	xp[ds++] = 0;
+    }
+
+    if (is_negative) {
+	*hp = make_neg_bignum_header(sz-1);
+    } else {
+	*hp = make_pos_bignum_header(sz-1);
+    }
+    return res;
+}
+
+/*
+ * The following code is used when a guard that may build on the
+ * heap is called directly. They must not use HAlloc(), but must
+ * do a garbage collection if there is insufficient heap space.
+ */
+
+#define ERTS_NEED_GC(p, need) ((HEAP_LIMIT((p)) - HEAP_TOP((p))) <= (need))
+
+Eterm erts_gc_length_1(Process* p, Eterm* reg, Uint live)
+{
+    Eterm list = reg[live];
+    int i;
+
+    if (is_nil(list)) 
+	return SMALL_ZERO;
+    i = 0;
+    while (is_list(list)) {
+	i++;
+	list = CDR(list_val(list));
+    }
+    if (is_not_nil(list))  {
+	BIF_ERROR(p, BADARG);
+    }
+    return make_small(i);
+}
+
+Eterm erts_gc_size_1(Process* p, Eterm* reg, Uint live)
+{
+    Eterm arg = reg[live];
+    if (is_tuple(arg)) {
+	Eterm* tupleptr = tuple_val(arg);
+	return make_small(arityval(*tupleptr));
+    } else if (is_binary(arg)) {
+	Uint sz = binary_size(arg);
+	if (IS_USMALL(0, sz)) {
+	    return make_small(sz);
+	} else {
+	    Eterm* hp;
+	    if (ERTS_NEED_GC(p, BIG_UINT_HEAP_SIZE)) {
+		erts_garbage_collect(p, BIG_UINT_HEAP_SIZE, reg, live);
+	    }
+	    hp = p->htop;
+	    p->htop += BIG_UINT_HEAP_SIZE;
+	    return uint_to_big(sz, hp);
+	}
+    }
+    BIF_ERROR(p, BADARG);
+}
+
+Eterm erts_gc_bit_size_1(Process* p, Eterm* reg, Uint live)
+{
+    Eterm arg = reg[live];
+    if (is_binary(arg)) {
+	Uint low_bits;
+	Uint bytesize;
+	Uint high_bits;
+	bytesize = binary_size(arg);
+	high_bits = bytesize >>  ((sizeof(Uint) * 8)-3);
+	low_bits = (bytesize << 3) + binary_bitsize(arg);
+	if (high_bits == 0) {
+	    if (IS_USMALL(0,low_bits)) {
+		return make_small(low_bits);
+	    } else {
+		Eterm* hp; 
+		if (ERTS_NEED_GC(p, BIG_UINT_HEAP_SIZE)) {
+		    erts_garbage_collect(p, BIG_UINT_HEAP_SIZE, reg, live);
+		}
+		hp = p->htop;
+		p->htop += BIG_UINT_HEAP_SIZE;
+		return uint_to_big(low_bits, hp);
+	    }
+	} else {
+	    Uint sz = BIG_UINT_HEAP_SIZE+1;
+	    Eterm* hp;
+	    if (ERTS_NEED_GC(p, sz)) {
+		erts_garbage_collect(p, sz, reg, live);
+	    }
+	    hp = p->htop;
+	    p->htop += sz;
+	    hp[0] = make_pos_bignum_header(sz-1);
+	    BIG_DIGIT(hp,0) = low_bits;
+	    BIG_DIGIT(hp,1) = high_bits;
+	    return make_big(hp);
+	}
+    } else {
+	BIF_ERROR(p, BADARG);
+    }
+}
+
+Eterm erts_gc_byte_size_1(Process* p, Eterm* reg, Uint live)
+{
+    Eterm arg = reg[live];
+    if (is_binary(arg)) {
+	Uint bytesize = binary_size(arg);
+	if (binary_bitsize(arg) > 0) {
+	    bytesize++;
+	}
+	if (IS_USMALL(0, bytesize)) {
+	    return make_small(bytesize);
+	} else {
+	    Eterm* hp;
+	    if (ERTS_NEED_GC(p, BIG_UINT_HEAP_SIZE)) {
+		erts_garbage_collect(p, BIG_UINT_HEAP_SIZE, reg, live);
+	    }
+	    hp = p->htop;
+	    p->htop += BIG_UINT_HEAP_SIZE;
+	    return uint_to_big(bytesize, hp);
+	}
+    } else {
+	BIF_ERROR(p, BADARG);
+    }
+}
+
+Eterm erts_gc_abs_1(Process* p, Eterm* reg, Uint live)
+{
+    Eterm arg;
+    Eterm res;
+    Sint i0, i;
+    Eterm* hp;
+
+    arg = reg[live];
+
+    /* integer arguments */
+    if (is_small(arg)) {
+	i0 = signed_val(arg);
+	i = labs(i0);
+	if (i0 == MIN_SMALL) {
+	    if (ERTS_NEED_GC(p, BIG_UINT_HEAP_SIZE)) {
+		erts_garbage_collect(p, BIG_UINT_HEAP_SIZE, reg, live+1);
+		arg = reg[live];
+	    }
+	    hp = p->htop;
+	    p->htop += BIG_UINT_HEAP_SIZE;
+	    return uint_to_big(i, hp);
+	} else {
+	    return make_small(i);
+	}
+    } else if (is_big(arg)) {
+	if (!big_sign(arg)) {
+	    return arg;
+	} else {
+	    int sz = big_arity(arg) + 1;
+	    Uint* x;
+
+	    if (ERTS_NEED_GC(p, sz)) {
+		erts_garbage_collect(p, sz, reg, live+1);
+		arg = reg[live];
+	    }
+	    hp = p->htop;
+	    p->htop += sz;
+	    sz--;
+	    res = make_big(hp);
+	    x = big_val(arg);
+	    *hp++ = make_pos_bignum_header(sz);
+	    x++;                          /* skip thing */
+	    while(sz--)
+		*hp++ = *x++;
+	    return res;
+	}
+    } else if (is_float(arg)) {
+	FloatDef f;
+
+	GET_DOUBLE(arg, f);
+	if (f.fd < 0.0) {
+	    if (ERTS_NEED_GC(p, FLOAT_SIZE_OBJECT)) {
+		erts_garbage_collect(p, FLOAT_SIZE_OBJECT, reg, live+1);
+		arg = reg[live];
+	    }
+	    hp = p->htop;
+	    p->htop += FLOAT_SIZE_OBJECT;
+	    f.fd = fabs(f.fd);
+	    res = make_float(hp);
+	    PUT_DOUBLE(f, hp);
+	    return res;
+	}
+	else
+	    return arg;
+    }
+    BIF_ERROR(p, BADARG);
+}
+
+Eterm erts_gc_float_1(Process* p, Eterm* reg, Uint live)
+{
+    Eterm arg;
+    Eterm res;
+    Eterm* hp;
+    FloatDef f;
+     
+    /* check args */
+    arg = reg[live];
+    if (is_not_integer(arg)) {
+	if (is_float(arg))  {
+	    return arg;
+	} else {
+	badarg:
+	    BIF_ERROR(p, BADARG);
+	}
+    }
+    if (is_small(arg)) {
+	Sint i = signed_val(arg);
+	f.fd = i;		/* use "C"'s auto casting */
+    } else if (big_to_double(arg, &f.fd) < 0) {
+	goto badarg;
+    }
+    if (ERTS_NEED_GC(p, FLOAT_SIZE_OBJECT)) {
+	erts_garbage_collect(p, FLOAT_SIZE_OBJECT, reg, live+1);
+	arg = reg[live];
+    }
+    hp = p->htop;
+    p->htop += FLOAT_SIZE_OBJECT;
+    res = make_float(hp);
+    PUT_DOUBLE(f, hp);
+    return res;
+}
+
+Eterm erts_gc_round_1(Process* p, Eterm* reg, Uint live)
+{
+    Eterm arg;
+    FloatDef f;
+     
+    arg = reg[live];
+    if (is_not_float(arg)) {
+	if (is_integer(arg))  {
+	    return arg;
+	}
+	BIF_ERROR(p, BADARG);
+    }
+    GET_DOUBLE(arg, f);
+
+    return gc_double_to_integer(p, (f.fd > 0.0) ? f.fd + 0.5 : f.fd - 0.5,
+				reg, live);
+}
+
+Eterm erts_gc_trunc_1(Process* p, Eterm* reg, Uint live)
+{
+    Eterm arg;
+    FloatDef f;
+     
+    arg = reg[live];
+    if (is_not_float(arg)) {
+	if (is_integer(arg))  {
+	    return arg;
+	}
+	BIF_ERROR(p, BADARG);
+    }
+    /* get the float */
+    GET_DOUBLE(arg, f);
+
+    /* truncate it and return the resultant integer */
+    return gc_double_to_integer(p, (f.fd >= 0.0) ? floor(f.fd) : ceil(f.fd),
+				reg, live);
+}
+
+static Eterm
+gc_double_to_integer(Process* p, double x, Eterm* reg, Uint live)
+{
+    int is_negative;
+    int ds;
+    ErtsDigit* xp;
+    int i;
+    Eterm res;
+    size_t sz;
+    Eterm* hp;
+    double dbase;
+
+    if ((x < (double) (MAX_SMALL+1)) && (x > (double) (MIN_SMALL-1))) {
+	Sint xi = x;
+	return make_small(xi);
+    }
+
+    if (x >= 0) {
+	is_negative = 0;
+    } else {
+	is_negative = 1;
+	x = -x;
+    }
+
+    /* Unscale & (calculate exponent) */
+    ds = 0;
+    dbase = ((double)(D_MASK)+1);
+    while(x >= 1.0) {
+	x /= dbase;         /* "shift" right */
+	ds++;
+    }
+    sz = BIG_NEED_SIZE(ds);          /* number of words including arity */
+    if (ERTS_NEED_GC(p, sz)) {
+	erts_garbage_collect(p, sz, reg, live);
+    }
+    hp = p->htop;
+    p->htop += sz;
+    res = make_big(hp);
+    xp = (ErtsDigit*) (hp + 1);
+
+    for (i = ds-1; i >= 0; i--) {
+	ErtsDigit d;
+
+	x *= dbase;      /* "shift" left */
+	d = x;            /* trunc */
+	xp[i] = d;        /* store digit */
+	x -= d;           /* remove integer part */
+    }
+    while ((ds & (BIG_DIGITS_PER_WORD-1)) != 0) {
+	xp[ds++] = 0;
+    }
+
+    if (is_negative) {
+	*hp = make_neg_bignum_header(sz-1);
+    } else {
+	*hp = make_pos_bignum_header(sz-1);
+    }
+    return res;
+}