"

 COPYRIGHT (c) 1993 by Claus Gittinger

 COPYRIGHT (c) 2018 Jan Vrany

 COPYRIGHT (c) 2020 LabWare

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

"{ Package: 'stx:libbasic' }"

"{ NameSpace: Smalltalk }"

UninterpretedBytes subclass:#ExternalBytes

	instanceVariableNames:'address* size'

	classVariableNames:'AllocatedInstances Lobby DebugMalloc TraceMalloc'

	poolDictionaries:''

	category:'System-Support'

!

!ExternalBytes primitiveDefinitions!

%{

    #include <stdlib.h>

    #include <stdio.h>

// cg: not needed

#if 0

# ifdef __osx__

#  include <sys/malloc.h>

# else

#  include <malloc.h>

# endif

#endif

    extern char *__stx_malloc(size_t);

    extern char *__stx_calloc(size_t, size_t);

    extern char *__stx_realloc(char *, size_t);

    extern void __stx_free(char *);

    extern void __stx_mallocStatistics(void);

%}

! !

!ExternalBytes primitiveFunctions!

%{

struct mallocList {

	char *chunk;

	size_t size;

	struct mallocList *next;

};

static struct mallocList *mallocList = (struct mallocList *)0;

static INT mallocCount = 0;

static void

removeFromMallocList(char *ptr)

{

    struct mallocList *this, *prev, *next;

    int found = 0;

    if (@global(DebugMalloc) != true) return;

    if (ptr) {

	found = 0;

	for (this=mallocList, prev=0; this; this=next) {

	    next = this->next;

	    if (this->chunk == ptr) {

		if (prev) {

		    prev->next = next;

		} else {

		    mallocList = next;

		}

		free(this);

		found++;

		mallocCount--;

	    } else {

		prev = this;

	    }

	}

	if (! found) {

	    console_printf("ExternalBytes [warning]: **** free: alien %"_lx_" (allocated somewhere else ?))\n", (INT)ptr);

	}

    }

}

static void

addToMallocList(char *ptr, size_t nBytes)

{

    struct mallocList *e, *this;

    void *malloc();

    int found;

    if (@global(DebugMalloc) != true) return;

    if (ptr) {

	found = 0;

	for (this=mallocList; this; this=this->next) {

	    if (this->chunk == ptr) {

		console_printf("ExternalBytes [warning]: **** %016"_lx_" already allocated (freed somewhere else ?)\n", (INT)ptr);

		found++;

	    }

	}

	if (! found) {

	    e = (struct mallocList *) malloc(sizeof(struct mallocList));

	    e->next = mallocList;

	    e->chunk = ptr;

	    e->size = nBytes;

	    mallocList = e;

	    mallocCount++;

	}

    }

}

char *

__stx_malloc(size_t nBytes) {

	char *ptr = malloc(nBytes);

	if (@global(TraceMalloc) == true) {

	    console_printf("ExternalBytes [info]: allocated %d bytes at: %016"_lx_"\n", nBytes, (INT)ptr);

	}

	addToMallocList(ptr, nBytes);

	return ptr;

}

char *

__stx_calloc(size_t n, size_t size) {

	char *ptr = __stx_malloc(n * size);

	if (ptr != 0) {

	    bzero(ptr, (n * size));

	}

	return ptr;

}

char *

__stx_realloc(char *ptr, size_t nBytes)

{

	char *newPtr;

	removeFromMallocList(ptr);

	newPtr = realloc(ptr, nBytes);

	addToMallocList(newPtr, nBytes);

	if (@global(TraceMalloc) == true) {

	    console_printf("ExternalBytes [info]: realloc %d bytes for %"_lx_" at: %"_lx_"\n", nBytes, (INT)ptr, (INT)newPtr);

	}

	return newPtr;

}

void

__stx_free(char *ptr)

{

	if (@global(TraceMalloc) == true) {

	    console_printf("ExternalBytes: free bytes at: %"_lx_"\n", (INT)ptr);

	}

	removeFromMallocList(ptr);

	free(ptr);

}

void

__stx_mallocStatistics() {

	struct mallocList *this;

	int amount = 0;

	int n = 0;

	for (this=mallocList; this; this=this->next) {

	    n++;

	    amount += this->size;

	}

	console_printf("ExternalBytes [info]: allocated %d blocks with %d bytes overall\n", n, amount);

}

%}

! !

!ExternalBytes class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1993 by Claus Gittinger

 COPYRIGHT (c) 2018 Jan Vrany

 COPYRIGHT (c) 2020 LabWare

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

!

documentation

"

    This class provides access to any memory in the system. Its main purpose

    is to provide a baseclass for objects referencing structured external data.

    Normally, instances are created by primitive code which wants to pass C-data

    to Smalltalk AND grants smalltalk access to individual bytes afterwards.

    Primitives which do not want to grant this access should return instances of

    ExternalAddress. See more info there. Also, have a look at ExternalFunction

    which is another similar class, but specialized to represent callable C-functions.

    Since the memory address of an instance stays fixed (once allocated),

    it can also be used to share data with external C-parts

    (which are not prepared for objects to change their address).

    Use with great care - access is not always checked for out-of-bounds

    or valid addresses.

    Since the data is allocated outside the garbage collected smalltalk space,

    its address stays fix. Thus, it can be passed to external C-functions without

    any danger. However, you have to take care for freeing the memory yourself.

    To help in avoiding memory bugs, instances created with #new: are

    registered in a local classvar and deregistered when the underlying memory

    is explicitely freed. Since a life reference (from that classvar) exists,

    the garbage collector will never find these to be reclaimable, and the

    underlying memory stays allocated (at a fix address) forever.

    To release the memory, either #free it or #unprotect it.

    The first will immediately release the memory, while the second will delay

    freeing until the next garbage collect occurs.

    If you need memory which is automatically freed, create

    the instance via #unprotectedNew: right away; the underlying malloced-memory

    will be released as soon as no smalltalk reference to the ExtBytes object

    exists any more (however, you have to know for sure, that no C-references

    exist to this memory).

    To release all memory call #releaseAllMemory which simply sets the

    AllocatedInstances class variable to nil (thus releasing those refs).

    Example (automatic freeing as soon as ref to buffer is gone):

	|buffer|

	buffer := ExternalBytes unprotectedNew:100.

	...

    Example (manual freeing - never freed, if ref to buffer is gone):

	|buffer|

	buffer := ExternalBytes new:100.

	...

	buffer free

    Example (delayed automatic freeing as soon as ref to buffer is gone):

	|buffer|

	buffer := ExternalBytes new:100.

	...

	buffer unregister

    This class only supports unstructured external data

    - see the companion class ExternalStructure for more.

    Notice: support for external data is still being developed -

	    a parser for C structure syntax and typedefs is on the way,

	    making shared data with C programs much easier in the future.

    Also notice, that this class may not be available or behave different

    in other smalltalk systems, making code using it very unportable.

    It is provided for C interfacing only.

    Finally note, that ST/X's memory system is much faster than malloc/free

    in the normal case - especially for short term temporary objects,

    automatically reclaimed object memory is about 5-10 times faster than

    malloc/free.

    Things may be different for huge byte-valued objects, which are to be

    reclaimed by the oldspace colletor.

    Anyway, for portability, we strongly warn from using this as a substitute

    for byteArrays; it is meant for shared data with external C-functions ONLY.

    Debugging:

	since all manual memory systems are subject of obscure errors,

	you may want to turn malloc-tracing on; this traces all allocations/frees

	done here. To do this, evaluate: 'ExternalBytes mallocTrace:true'.

	In addition, you may turn on full debugging (with 'ExternalBytes mallocDebug:true');

	if turned on, all malloc/realloc requests are remembered and later free / realloc

	requests validated against this list (i.e. to detect freeing unallocated chunks).

	To benefit from this in C-code, we recommend you use __stx_malloc() / __stx_free()

	instead of malloc() / free(). To do so, redefine them in a header file (or cc comand line)

	and recompile your external c-libraries with this.

	I used this here to find memory leaks in the Xt libraries (there are still some in

	the HTML widget ...). If mallocDebug is on, #dumpMallocChunks will print out what is

	leftOver. This may help to find trouble spots in your C-code.

    [author:]

	Claus Gittinger

    [see also:]

	ExternalAddress ExternalFunction

	ByteArray

	( how to write primitive code :html: programming/primitive.html )

"

!

examples

"

    These examples below are not directly executable;

    some require primitive code to be compiled, or are simply given as sceletton.

    Notice, that in C, indexing is 0-based, while in Smalltalk, indices start

    at 1.

    allocating memory in ST, passing it to C:

      in smalltalk:

	...

	bytes := ExternalBytes new:100.

	...

      in C (assuming that the bytes-object has been passed):

	...

	char *bytePtr;

	bytePtr = (char *)(__externalBytesAddress(bytes));

	if (bytePtr) {

	    ... do something with bytes at bytePtr ...

	}

      freeing (in ST):

	...

	bytes free.

	...

    allocating memory in C, passing it to ST:

      in C:

	...

	char *bytePtr;

	bytePtr = (char *)(malloc(100));

	...

	RETURN (__MKEXTERNALBYTES(bytePtr));

      in Smalltalk (extracting bytes, integers or strings):

	byteVal := bytes byteAt:1.

	...

	intVal := bytes doubleWordAt:1 MSB:true.

	...

	string := bytes stringAt:20.

	...

    |data bytes2|

    data := #[0 1 2 3 4 5 6 7 8 9 9 8 7 6 5 4 3 2 1 0] copy.

    bytes2 := ExternalBytes new:30.

    bytes2 replaceBytesFrom:1 to:20 with:data startingAt:1.

    data replaceBytesFrom:2 to:20 with:bytes2 startingAt:1.

    bytes2

    |data bytes1 bytes2|

    data := #[0 1 2 3 4 5 6 7 8 9 9 8 7 6 5 4 3 2 1 0].

    bytes1 := ExternalBytes new:30.

    bytes2 := ExternalBytes new:30.

    bytes1 replaceBytesFrom:1 to:20 with:data startingAt:1.

    bytes2 atAllPut:99.

    bytes2 replaceBytesFrom:2 to:21 with:bytes1 startingAt:1.

    bytes2 asByteArray

    |data1 bytes1 data2|

    data1 := #[0 1 2 3 4 5 6 7 8 9 9 8 7 6 5 4 3 2 1 0].

    bytes1 := ExternalBytes new:30.

    bytes1 replaceBytesFrom:1 to:20 with:data1 startingAt:1.

    data2 := ByteArray new:30 withAll:99.

    data2 replaceBytesFrom:2 to:21 with:bytes1 startingAt:1.

    data2

"

! !

!ExternalBytes class methodsFor:'initialization'!

initialize

    Lobby isNil ifTrue:[

	Lobby := Registry new.

    ]

! !

!ExternalBytes class methodsFor:'instance creation'!

address:anAddressInteger

    "return a new ExternalBytes object to access bytes starting at anAddressInteger.

     The memory at anAddressInteger has been allocated elsewhere.

     The size is not known, therefore byte accesses will NOT be checked for valid index.

     Use this, if you get a pointer from some external source (such as a

     C-callBack function) and you have to extract bytes from that.

     DANGER ALERT: this method allows very bad things to be done to the

		   system - use with GREAT care (better: do not use it)"

    ^ self basicNew setAddress:anAddressInteger size:nil

    "Modified (comment): / 31-03-2016 / 11:05:07 / cg"

!

address:anAddressInteger size:size

    "return a new ExternalBytes object to access bytes starting at anAddressInteger.

     The memory at anAddressInteger has been allocated elsewhere.

     The size is known, which allows byte accesses to be checked for valid index.

     Use this, if you get a pointer to a structure from some external source

     (such as a C-callBack function) and you have to extract things from that.

     DANGER ALERT: this method allows very bad things to be done to the

		   system - use with GREAT care (better: do not use it)"

    ^ self basicNew setAddress:anAddressInteger size:size

    "Modified (comment): / 31-03-2016 / 11:04:27 / cg"

!

fromExternalAddress: anExternalAddress

    "Creates a new instance referring to the same

     memory as parameter `anExternalAddress`.

     This method is called by FFI (ExternalLibraryFunction)

     to create a return value of this type.

    "

    ^ self basicNew 

        setAddress: anExternalAddress size: 0;

        yourself.

    "Created: / 24-12-2014 / 22:18:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 25-12-2014 / 10:33:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 22-06-2020 / 23:47:24 / Jan Vrany <jan.vrany@labware.com>"

!

new:numberOfBytes

    "allocate some memory usable for data;

     the memory safe from being finalized by the garbage collector.

     Return a corresponding ExternalBytes object or raise MallocFailure (if malloc fails).

     Use this, if you have to pass a block of bytes to some

     external destination (such as a C function) which does not copy the

     data, but instead keeps a reference to it. For example, many functions

     which expect strings simply keep a ref to the passed string - for those,

     an ST/X string-pointer is not the right thing to pass, since ST/X objects

     may change their address.

     DANGER ALERT: the memory is NOT automatically freed until it is either

		   MANUALLY freed (see #free) or the returned externalBytes object

		   is unprotected or the classes releaseAllMemory method is called."

    |newInst|

    newInst := self unprotectedNew:numberOfBytes.

    newInst protectFromGC.

    ^ newInst

    "

     |bytes|

     bytes := ExternalBytes new:100.

     bytes wordAt:1 put:1.

     bytes doubleWordAt:3 put:16r12345678.

     bytes inspect

    "

!

newNullTerminatedFromString:aString

    "allocate a null terminated string containing the chars of aString"

    |nChars extBytes|

    nChars := aString size.

    self assert:(aString bitsPerCharacter == 8).

    extBytes := self new:nChars+1.

    extBytes replaceBytesFrom:1 to:nChars with:aString startingAt:1.

    extBytes at:nChars+1 put:0.

    ^ extBytes

!

newNullTerminatedFromWideString:aString

    "allocate a null terminated wide string containing the U16-chars of aString"