Native Pointers in XLISP-STAT

Luke Tierney

1998/01/08

Outline and Interface

A representation for native pointers has been added to XLISP-STAT. In addition to avoiding issues of casting to a FIXNUM, the pointer cell, constructed by newnatptr, allows a Lisp object to be registered for protection whenever the pointer cell is accessible. The first argument to newnatptr is the pointer value; the second argument is the protected item.

<declaration of newnatptr>= (U->)
extern LVAL newnatptr _((ALLOCTYPE *p, LVAL v));

Defines newnatptr (links are to index).

The address-of function has been modified to return native pointer objects. Other pointer-returning functions will also be modified accordingly. [I have not modified peek and poke---I'm not sure they are of much use in any case.]

To see why protection is needed, consider the function

(defun f (x) (g (array-data-address x)))

In the interpreter, the fact that x is on the stack protects it from garbage collection while g executes. But the compiler eliminates the current stack frame at the tail call, so if no more references to the value of x exist, it may be collected, making the address in use by g invalid. Protecting the value of x in the pointer object prevents this.

Two functions are provided for examining pointers. pointer-address returns the address of a pointer object as an integer (a BIGNUM if necessary). The function pointer-protected returns the item in the protected field of the pointer object. Both these routines are primarily useful for debugging. These functions are exported from the SYSTEM package (currently just a nickname for the XLISP package). The type of a pointer object is pointer.

> (use-package "SYSTEM")
> T
> (setf a (address-of pi))
#<Pointer: #4001f5f8>
> (pointer-address a)
1073870328
> (pointer-protected a)
3.141592653589793
> (type-of a)
POINTER
> (typep a 'pointer)
T

The result of the previous (address-of x) definition can be obtained by

(pointer-address (address-of x))

This is almost equivalent---for large poinbters this returns a BIGNUM instead of a negative FIXNUM under two's complement.

In addition, the function pointer-increment can be used to compute a new pointer with a specified offset from the old pointer. The function takes two or three arguments,

(pointer-increment p count)
(pointer-increment p count size)

The new pointer is offset by count * size bytes; if count is not supplied it defaults to one. The new pointer protects the same object as the old pointer. Either count or size may be negative.

When a pointer object is saved in a workspace its address value is ignored; when it is restored, the address is set to zero.

Implementation

The changes to implement native pointers are given as a patch file corresponding to

cvs diff -D 1/1/98 -D 1/8/98

Allocation and Workspaces

Native pointers use the CONS representation. The CAR cell holds the pointer, cast to an LVAL. The CDR cell holds a reference that is to be protected when the pointer cell is accessible. The constructor function is newnatptr.

<definition of newnatptr>= (U->)
> }
> 
> LVAL newnatptr P2C(ALLOCTYPE *, p, LVAL, v)
> {
>   LVAL val;
>   xlprot1(v);
>   val = newnode(NATPTR);
>   car(val) = (LVAL) p;
>   cdr(val) = v;
>   xlpop();
>   return val;

Defines newnatptr (links are to index).

For the generational collector, the properties of the new type are registered as

<generational GC properties of NATPTR type>= (U->)
>     type_info[NATPTR].allocated = FALSE;
>     type_info[NATPTR].has_children = TRUE;

A new case is added to the forward_children macro to follow the CDR cell only.

<case for forward_children macro>= (U->)
>   case NATPTR: \
>     forward_node(cdr(temp)); \
>     break; \

For the mark and sweep collector, the mark loop needs to have a final else clause of the form

<additional else clause for mark-and-sweep>= (U->)
>       else if (type == NATPTR) {
>       mark(cdr(this));

This code has not been tested since I don't use this collector.

The xldmem.h header file contains some accessor macros.

<accessor macros for native pointers>= (U->)
> /* native pointers *//* L. Tierney */
> /* Use the CONS representation with pointer in the CAR cell */
> #define getnpaddr(x)    ((ALLOCTYPE *) car(x))
> #define setnpaddr(x,v)  (car(x) = (LVAL) (v))
> #define getnpprot(x)    cdr(x)
> #define setnpprot(x,v)  rplacd(x,v)

Defines getnpaddr, getnpprot, setnpaddr, setnpprot (links are to index).

The tag value is set by

<tag value for NATPTR>= (U->)
> #define NATPTR  12  /* native pointer */

Defines NATPTR (links are to index).

The CONS-like type tags are renumbered.

<tag value renumbering>= (U->)
< #define CONS  12
< #define COMPLEX 13
---
> #define CONS  13
> #define COMPLEX 14
259c267
< #define RATIO 14
---
> #define RATIO 15
261,263c269,271
< #define USTREAM 15
< #define DARRAY  16
< #define RNDSTATE 17
---
> #define USTREAM 16
> #define DARRAY  17
> #define RNDSTATE 18
265c273
< #define BCCLOSURE 18
---
> #define BCCLOSURE 19

Because of this renumbering, renumbering the version has been incremented to 3.51 to invalidate old workspaces.

<version renumbering>= (U->)
< #define XLS_MINOR_RELEASE 50
---
> #define XLS_MINOR_RELEASE 51

The CONS-handling code for workspace saving is modified to only follow the CDR for NATPTR objects.

<modified CONS case for saving>= (U->)
<               writeptr(cvoptr(car(p)));
---
>               if (ntype(p) != NATPTR)
>                 writeptr(cvoptr(car(p)));

The restoration code places a zero in the CAR field of native pointer cells.

<modified CONS case for restoring>= (U->)
<           rplaca(p,cviptr(readptr()));
---
>           rplaca(p,type==NATPTR ? NULL : cviptr(readptr()));

User Functions

The address-of function has been modified to return a native pointer instead of a FIXNUM.

<changes to xaddrs>= (U->)
<     /* return the address of the node */
<     return (cvfixnum((FIXTYPE)val));
---
>     /* changed to use native pointer -- L. Tierney */
>     return newnatptr(val, val);

The function pointer-address retrieves the address cell of a native pointer as an integer. The value is returned as a BIGNUM if necessary.

<definition of xnpaddr>= (U->)
> /* xnpaddr - get the address of a native pointer */
> LVAL xnpaddr(V)
> {
>   LVAL p = xlganatptr();
>   xllastarg();
> #ifdef BIGNUMS
>   if ((unsigned long) getnpaddr(p) > MAXFIX)
>     return cvtulongbignum((unsigned long) getnpaddr(p), 0);
> #endif /* BIGNUMS */
>   return cvfixnum((FIXTYPE) getnpaddr(p));
> }

Defines xnpaddr (links are to index).

<function table entries>= (U->) [D->]
> {   "SYSTEM:POINTER-ADDRESS", S, xnpaddr },

Defines [[pointer-address]] (links are to index).

The pointer-protect function retrieves the protected value of a native pointer cell.

<definition of xnpprot>= (U->)
> /* xnpprot - get the protected value of a native pointer */
> LVAL xnpprot(V)
> {
>   LVAL p = xlganatptr();
>   xllastarg();
>   return getnpprot(p);
> }

Defines xnpprot (links are to index).

<function table entries>+= (U->) [<-D->]
> {   "SYSTEM:POINTER-PROTECTED", S, xnpprot },

Defines pointer-protect (links are to index).

The function pointer-increment returns a new pointer cell with its pointer value incremented by the product of the second and third arguments. [Should the arguments be allowed to be bignums?] The third argument is optional and defaults to one. The new pointer protects the same value as the original pointer. Either of the second and third arguments may be negative.

<definition of xnpincr>= (U->)
> /* xnpincr - increment native pointer */
> LVAL xnpincr(V)
> {
>   LVAL p = xlganatptr();
>   long count = getfixnum(xlgafixnum());
>   long size = moreargs() ? getfixnum(xlgafixnum()) : 1;
>   xllastarg();
>   return newnatptr(((char *) p) + count * size, getnpprot(p));
> }

Defines xnpincr (links are to index).

<function table entries>+= (U->) [<-D]
> {   "SYSTEM:POINTER-INCREMENT", S, xnpincr },

Defines pointer-increment (links are to index).

A line has to be added to the extern declarations in xlftab.h

<new declarations in xlftab.h>= (U->)
>     xnpaddr(V),xnpprot(V),xnpincr(V),

Defines xnpaddr, xnpincr, xnpprot (links are to index).

Type Information and Hashing

A new global variable is added to represent the native pointer type.

<declaration of a_ptr>= (U->)
> XLGLOBAL LVAL a_ptr;

Defines a_ptr (links are to index).

<definition of a_ptr>= (U->)
> LVAL a_ptr=NULL;

Defines a_ptr (links are to index).

<initialization of a_ptr>= (U->)
>     a_ptr        = xlenter("SYSTEM:POINTER");

There are new cases in the internal type-of and typep to handle the new type.

<new case in internal type-of>= (U->)
>     case NATPTR:      return (a_ptr);

<new case in internal typep>= (U->)
>   if (arg == a_ptr)       return NATPTR;

New predicate and argument reading macros are provided in xlisp.h.

<predicate macro for native pointers>= (U->)
> #define natptrp(x)      (ntype(x) == NATPTR)   /* L. Tierney */

Defines natptrp (links are to index).

<argument reader macro for native pointers>= (U->)
> #define xlganatptr()    (testarg(typearg(natptrp)))

Defines xlganatptr (links are to index).

The internal hash function xlhash is modified with a new ending clause of

<xlhash changes, part 1>= (U->)
<         default:    /* all array types */
<             for (i = getsize(obj), tot = 0; i-- > 0;)
---
>         default:
>           if (ntype(obj) >= ARRAY) { /* all array types */
>             for (i = getsize(obj), tot = 0; i-- > 0;)

<xlhash changes, part 2>= (U->)
<             return (int)(tot % len);
---
>             return (int)(tot % len);
>           }
>           else
>             return 0;   /* nothing we can do on this */

This may not be the best choice, but it fixes a fatal bug that made hashing things like random state objects fail.

Printing and Reading

A native pointer cell is printed as an unreadable form when *print-escape* is true and is printed as a hexadecimal number if *print-escape* is false.

<printing code for native pointers>= (U->)
>     case NATPTR:  /* L. Tierney */
> #ifdef PRINTCIRCLE
>           if (checkcircle(fptr, vptr)) break;
> #endif /* PRINTCIRCLE */
>           checkreadable(vptr);
>           if (flag) {
>             sprintf(buf, "#<%s: #", "Pointer");
>             xlputstr(fptr, buf);
>           }
>           sprintf(buf, AFMT, CVPTR(getnpaddr(vptr)));
>           xlputstr(fptr, buf);
>           if (flag)
>             xlputc(fptr, '>');
>           break;

The reading code just adds NATPTR to the cases that do not require special handling in a circular read. [I'm not sure if this is right, given #. constructs, for any of the things in this list for that matter.]

<extra case for read code>= (U->)
>   case NATPTR:

The Patch File

<patch file>=
Index: objects.c
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/objects.c,v
retrieving revision 1.21
retrieving revision 1.22
diff -r1.21 -r1.22
1247c1247
< #define FIRST_METHOD_OFFSET 530
---
> #define FIRST_METHOD_OFFSET 540
Index: version.h
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/version.h,v
retrieving revision 1.43
retrieving revision 1.44
diff -r1.43 -r1.44
2c2
<version renumbering>
Index: xldmem.c
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xldmem.c,v
retrieving revision 1.30
retrieving revision 1.31
diff -r1.30 -r1.31
221a222,223
<generational GC properties of NATPTR type>
919a922,924
<case for forward_children macro>
2300,2302c2305,2306
<       else {
<       if (is_array_type(type))
<         for (i = 0, n = getsize(this); i < n; i++)
---
>       else if (is_array_type(type)) {
>         for (i = 0, n = getsize(this); i < n; i++) 
2304a2309,2312
>         break;
>       }
<additional else clause for mark-and-sweep>
2306a2315,2316
>       else
>       break;
2936a2947,2957
<definition of newnatptr>
Index: xldmem.h
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xldmem.h,v
retrieving revision 1.14
retrieving revision 1.15
diff -r1.14 -r1.15
202a203,209
<accessor macros for native pointers>
> 
253a261
<tag value for NATPTR>
256,257c264,265
<tag value renumbering>
479a488
> <declaration of newnatptr>
Index: xlftab.c
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xlftab.c,v
retrieving revision 1.27
retrieving revision 1.30
diff -r1.27 -r1.30
324a325,327
<function table entries>
854a858,864
> {   NULL,               S, xnotimp      },
> {   NULL,               S, xnotimp      },
> {   NULL,               S, xnotimp      },
> {   NULL,               S, xnotimp      },
> {   NULL,               S, xnotimp      },
> {   NULL,               S, xnotimp      },
> {   NULL,               S, xnotimp      },
Index: xlftab.h
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xlftab.h,v
retrieving revision 1.26
retrieving revision 1.27
diff -r1.26 -r1.27
59a60
<new declarations in xlftab.h>
Index: xlglob.c
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xlglob.c,v
retrieving revision 1.17
retrieving revision 1.18
diff -r1.17 -r1.18
140a141
<definition of a_ptr>
Index: xlglob.h
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xlglob.h,v
retrieving revision 1.13
retrieving revision 1.14
diff -r1.13 -r1.14
112a113
<declaration of a_ptr>
Index: xlimage.c
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xlimage.c,v
retrieving revision 1.20
retrieving revision 1.21
diff -r1.20 -r1.21
130a131
>           case NATPTR:
133c134,135
<modified CONS case for saving>
335a338
>       case NATPTR:
338c341
<modified CONS case for restoring>
Index: xlinit.c
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xlinit.c,v
retrieving revision 1.26
retrieving revision 1.29
diff -r1.26 -r1.29
551a552
<initialization of a_ptr>
Index: xlisp.h
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xlisp.h,v
retrieving revision 1.63
retrieving revision 1.65
diff -r1.63 -r1.65
1377a1378
<predicate macro for native pointers>
1420a1422
<argument reader macro for native pointers>
Index: xlprin.c
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xlprin.c,v
retrieving revision 1.29
retrieving revision 1.32
diff -r1.29 -r1.32
548a549,562
<printing code for native pointers>
Index: xlread.c
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xlread.c,v
retrieving revision 1.20
retrieving revision 1.21
diff -r1.20 -r1.21
301a302
<extra case for read code>
Index: xlsym.c
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xlsym.c,v
retrieving revision 1.20
retrieving revision 1.21
diff -r1.20 -r1.21
322,323c322,324
<xlhash changes, part 1>
325c326,329
<xlhash changes, part 2>
Index: xlsys.c
===================================================================
RCS file: /NOKOMIS/users/luke/SRC/xlispstat/xlsys.c,v
retrieving revision 1.21
retrieving revision 1.23
diff -r1.21 -r1.23
117a118
<new case in internal type-of>
160a162
<new case in internal typep>
635,636c637,638
<changes to xaddrs>
637a640,670
> 
<definition of xnpaddr>
> 
<definition of xnpprot>
> 
<definition of xnpincr>
>

Indices

Chunks

<accessor macros for native pointers>: D1, U2
<additional else clause for mark-and-sweep>: D1, U2
<argument reader macro for native pointers>: D1, U2
<case for forward_children macro>: D1, U2
<changes to xaddrs>: D1, U2
<declaration of a_ptr>: D1, U2
<declaration of newnatptr>: D1, U2
<definition of a_ptr>: D1, U2
<definition of newnatptr>: D1, U2
<definition of xnpaddr>: D1, U2
<definition of xnpincr>: D1, U2
<definition of xnpprot>: D1, U2
<extra case for read code>: D1, U2
<function table entries>: D1, D2, D3, U4
<generational GC properties of NATPTR type>: D1, U2
<initialization of a_ptr>: D1, U2
<modified CONS case for restoring>: D1, U2
<modified CONS case for saving>: D1, U2
<new case in internal type-of>: D1, U2
<new case in internal typep>: D1, U2
<new declarations in xlftab.h>: D1, U2
<patch file>: D1
<predicate macro for native pointers>: D1, U2
<printing code for native pointers>: D1, U2
<tag value for NATPTR>: D1, U2
<tag value renumbering>: D1, U2
<version renumbering>: D1, U2
<xlhash changes, part 1>: D1, U2
<xlhash changes, part 2>: D1, U2

Identifiers

a_ptr: D1, D2, U3, U4, U5
getnpaddr: D1, U2, U3
getnpprot: D1, U2, U3
NATPTR: U1, U2, U3, U4, D5, U6, U7, U8, U9, U10, U11, U12, U13
natptrp: D1, U2
newnatptr: D1, D2, U3, U4
[[pointer-address]]: D1
pointer-increment: D1
pointer-protect: D1
setnpaddr: D1
setnpprot: D1
xlganatptr: U1, U2, U3, D4
xnpaddr: D1, U2, D3
xnpincr: D1, U2, D3
xnpprot: D1, U2, D3