k+ reg tests

Author: ktye

k+/blas.c

@@ -15,21 +15,24 @@ uint64_t asum(uint64_t x){x=FZ(Fst(x));int32_t n=nn(x);if(tp(x)==Zt)n*=2;return
 uint64_t imax(uint64_t x){x=FZ(Fst(x));int32_t n=nn(x);int32_t i=tp(x)==Ft?cblas_idamax(n,FK(x),1):cblas_izamax(n,FK(x),1);return Ki(i);}
 uint64_t rot(uint64_t y){double c=f0(y),s=f1(y);uint64_t x=FZ(x2(y)),q=x3(y);dx(y);x=use(x);y=use(q);
  tp(x)==Zt?cblas_zdrot(nn(x),FK(x),1,FK(y),1,c,s):cblas_drot(nn(x),FK(x),1,FK(y),1,c,s);return l2(x,y);}
-uint64_t mv(uint64_t y){int32_t m,n; //todo..
- uint64_t A=FZ(x1(y)),x=FZ(x5(y)),r=FZ(x6(y));
- if(tp(A)==Zt){
-  double a=f0(y),b=f4(y);int32_t rA=i2(y),op=i3(y);dx(y);r=use(r);dim(A,rA,&m,&n);
-  cblas_dgemv(major(rA),trans(op),m,n,a,FK(A),n,FK(x),1,b,FK(r),1);
+uint64_t gemv(uint64_t u){int32_t m,n;
+//       0 1 2  3  4 5 6
+//y:gemm[a;A;rA;op;b;y;x]
+ uint64_t A=FZ(x1(u)),y=FZ(x5(u)),x=FZ(x6(u));
+ if(tp(A)==Ft){
+  double a=f0(y),b=f4(y);int32_t rA=i2(y),op=i3(y);dx(u);y=use(y);dim(A,rA,&m,&n);
+  cblas_dgemv(major(rA),trans(op),m,n,a,FK(A),n,FK(x),1,b,FK(y),1);
   dx(A);dx(x);return b;
  }else{
   printf("todo mv complex\n");
  }
 }
 
-void regblas(void){ //encode names with: https://play.golang.org/p/4ethx6OEVCR
+void blas(void){ //encode names with: https://play.golang.org/p/4ethx6OEVCR
  reg(nrm2,"nrm2",1); //c-func k-name arity
  reg(asum,"asum",1);
  reg(imax,"imax",1);
  reg(rot,  "rot",4);
- reg(mv,    "mv",7);
+ reg(gemv,"gemv",7);
 }
+__attribute((section("reg")))void*rblas=blas;

k+/curl.c

@@ -7,7 +7,7 @@ static size_t curlback(void *c,size_t n,size_t m,uint64_t*r){
  uint64_t x=*r;int32_t xn=nn(x);
  n*=m;x=uspc(x,Ct,n);*r=x;memcpy(M_+(int32_t)x+xn,c,n);return n;}
 
-uint64_t curl(uint64_t x){
+uint64_t kurl(uint64_t x){
  x=Fst(x);if(tp(x)!=Ct)trap();x=cat1(x,Kc(0));
  void*c=curl_easy_init();
  curl_easy_setopt(c,10002,M_+(int32_t)x);
@@ -19,4 +19,5 @@ uint64_t curl(uint64_t x){
  curl_easy_cleanup(c);
  dx(x);return r;}
 
-void regcurl(void){reg(curl,"curl",1);}
+void curl(void){reg(kurl,"curl",1);}
+__attribute((section("reg")))void*rcurl=curl;

k+/l.c

@@ -1,8 +1,7 @@
-#define NX 128 //large enough to hold all external functions
+#define NX 64 //large enough to hold all external functions
 
 typedef uint64_t (*XF)(uint64_t);
 uint64_t IX=0;XF xtab[NX];
-uint64_t hlp=0,help=0;
 void reg(XF f, const char*name, int32_t arity){
  uint64_t c=mk(Ct,(int32_t)strlen(name));
  if(!help){help=sc(Ku(1886152040ull));hlp=Key(mk(St,0),mk(It,0));}
@@ -12,17 +11,22 @@ void reg(XF f, const char*name, int32_t arity){
 
  hlp=Cat(hlp,Key(Enl(s),Enl(Ki(arity))));
 
+ //a native function has type 14 and stores 2 values:
+ // -any identifier, we use a primary function type 0 (no refcounts)
+ // -a strings with the name used to display the function object
+ //the identifier & the arglist is passed to native() when the function is called.
  int64_t l=ti(14,(uint32_t)l2(IX, c));
  SetI32((int32_t)l-12,arity);
- dx(Asn(s,l));
+ dx(Asn(s,l)); //assign the function object to a global symbol, for the user to access it.
+ if(NX==IX){fprintf(stderr,"xtab is too small: increase NX in l.c\n");exit(1);}
  xtab[IX++]=f;
 }
 int64_t cnative(int64_t x,int64_t y){return(int64_t)xtab[(int32_t)x](y);}
 
 
 
 //some helpers to unpack arguments
-static uint64_t FZ(int64_t x){
+static uint64_t FZ(int64_t x){ //real or complex vector arg
  int32_t xt=tp(x);
  if(xt<16)trap();
  if(xt<Ft){x=Add(Kf(0.0),x);}

k+/l.h

@@ -6,3 +6,9 @@ void sincos(double,double*,double*);
 static void sin1(int32_t,int32_t,int32_t);
 static void cos1(int32_t,int32_t,int32_t);
 #define cosin_(x,r,_) sincos(x,(double*)(M_+8+r),(double*)(M_+r));
+
+//we collect names and arity of extention functions in a dict assigned to "help"
+uint64_t hlp=0,help=0;
+
+//initialization magick, thanks @ovs.
+extern void(*__start_reg)(),(*__stop_reg)();

k+/readme

@@ -13,10 +13,11 @@
 
 # BLAS    /usr/include/x86_64-linux-gnu/cblas-netlib.h
 # nrm2[x] FZ  l2 vector norm         FZ mean double-float or complex vector
-# asum[x] FZ  l1 vector norm
-# imax[x] FZ  index of l1 max element
+# asum[x] FZ  l1 vector norm         some blas args are changed to facilitate projections
+# imax[x] FZ  index of l1 max element                               (changing input last)
 # rot[c;s;x;y] c:f s:f x:FZ y:FZ  plane rotation
-# mv[a;A;rA;op;b;x;y] c:fz A:FZ b:fz y:FZ  a*A*x+b*y
+# dot dotc todo
+# gemv[a;A;rA;op;b;y;x] c:fz A:FZ b:fz y:FZ  a*A*x+b*y
 #
 # CURL
 # curl"https://ktye.github.io/k.png"
@@ -28,23 +29,26 @@ set -x
 if [ "$1" = "get" ];then wget -Okc.orig https://github.com/ktye/i/releases/download/latest/k.c; fi
 
 L=""
-R=""
+W=""
 awk -f m.awk kc.orig |\
 sed -e 's/math.h>$/math.h>\n#include"l.h"/' \
-    -e 's/kinit()/kinit();libs()/' \
+    -e 's/kinit()/&;for(void(**f)()=\&__start_reg;f<\&__stop_reg;(*f++)());dx(Asn(help,hlp))/' \
            >k.c
 cat    m.c>>k.c
 cat    l.c>>k.c
 #           k.c
 
-#these lines can be uncommented individually:
-cat blas.c>>k.c;R="$R regblas();";L="$L -lopenblas"
-cat curl.c>>k.c;R="$R regcurl();";L="$L -lcurl"
+
+#these lines can be uncommented individually to exclude a package:
+cat blas.c>>k.c;L="$L -lopenblas";W="$W libopenblas.dll"
+cat curl.c>>k.c;L="$L -lcurl"    ;W="$W libcurl-x64.dll"
 #           k.c
 
-echo "void libs(void){$R dx(Asn(help,hlp));}" >> k.c
+#type help to see a the list of all registered functions and their arity
 
- K=-ok+
- C=cc
+if uname|grep Windows; then 
+ L="$W"; fi
  O="-O3 -march=native"
-$C $O $K k.c $L -lm
+ C=cc
+ K="-ok+ k.c"
+$C $O $K $L -lm

k+/tests/blas.t

@@ -0,0 +1,8 @@
+dim:(#;#*)@\ /
+A:4^1 2 3 4 2 1 2 1 0 3 5 2. /
+At:+A /
+A0:*At /
+dim A /4 3
+(nrm2 x)~%+/x*x:,/A /1
++/A*A0 /30. 27. 13.
+gemv[1.;,/At;3;0;0;4#0.;A0] /30. 27. 13.

k+/tests/readme

@@ -0,0 +1 @@
+$k+ *.t -e  #run all tests and exit