/erts/emulator/beam/erl_bif_guard.c

/*
 * %CopyrightBegin%
 *
 * Copyright Ericsson AB 2006-2010. 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;
}

/********************************************************************************
 * binary_part guards. The actual implementation is in erl_bif_binary.c
 ********************************************************************************/
BIF_RETTYPE binary_part_3(BIF_ALIST_3)
{
    return erts_binary_part(BIF_P,BIF_ARG_1,BIF_ARG_2, BIF_ARG_3);
}

BIF_RETTYPE binary_part_2(BIF_ALIST_2)
{
    Eterm *tp;
    if (is_not_tuple(BIF_ARG_2)) {
	goto badarg;
    }
    tp = tuple_val(BIF_ARG_2);
    if (arityval(*tp) != 2) {
	goto badarg;
    }
    return erts_binary_part(BIF_P,BIF_ARG_1,tp[1], tp[2]);
 badarg:
   BIF_ERROR(BIF_P,BADARG);
}


/*
 * 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.
 *
 * Important note: All error checking MUST be done before doing
 * a garbage collection. The compiler assumes that all registers
 * are still valid if a guard BIF generates an exception.
 */

#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;
}

/********************************************************************************
 * binary_part guards. The actual implementation is in erl_bif_binary.c
 ********************************************************************************/
Eterm erts_gc_binary_part_3(Process* p, Eterm* reg, Uint live)
{
    return erts_gc_binary_part(p,reg,live,0);
}

Eterm erts_gc_binary_part_2(Process* p, Eterm* reg, Uint live)
{
    return erts_gc_binary_part(p,reg,live,1);
}