libs/dynimport-simple.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; lazy importing from dynamic libraries, with SAVEing support
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 use-lib: asmx86
   9
  10 (*
  11 example:
  12
  13   dynlib: libc libc.so.6
  14
  15   dynlib-import: libc
  16   <libc-write> ssize_t write( int ( fd) , const void * ( buf) , size_t ( count) );
  17   <libc-printf> void printf( const char * ( fmt) , ... );  // this does remove all known args (i.e. "..." is left on the stack)
  18   end;
  19
  20   " HI!\n" swap 1 libc-write . cr
  21
  22   : testit  ( -- )  " HI!\n" swap 1 libc-write . cr ;
  23   : testpf  ( -- )  42 666 " 666=%d; 42=%d\n" drop libc-printf 2drop ;
  24
  25   testit
  26   testpf
  27   .stack bye
  28
  29 please, note that argument order is reverse for cdecl!
  30
  31 all floating point arguments are passed on the data stack as doubles.
  32 you can use "F>FPARG" to move fp argument from FP stack to the data stack.
  33
  34 to move function result back to FP stack, use "FPARG>F".
  35
  36 note that FP stack must be empty on function call. if you are not sure, you
  37 can use FP-WIPE to clear FP stack before invoking a function.
  38
  39   dynlib: libm libm.so.6
  40
  41   dynlib-import: libm
  42   <libm-pow> double pow( double , double );
  43   end;
  44
  45   : test-powf  ( -- )
  46     f# 2 f>fparg f# 3 f>fparg fp-wipe libm-powf
  47     " res=%g\n" drop libc-printf fparg-drop
  48   ;
  49
  50 this will print "9".
  51 *)
  52
  53
  54 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55 ;; clear FPU stack
  56 code: FP-WIPE  ( -- )
  57   emms
  58   urnext
  59 endcode
  60
  61 ;; move FP argument from FP stack to the data stack
  62 code: F>FPARG  ( -- n0 n1 )
  63   push  TOS
  64   push  TOS
  65   push  TOS
  66   fstp  qword [esp]
  67   pop   TOS
  68   urnext
  69 endcode
  70
  71 ;; move FP argument from the data stack to FP stack
  72 code: FPARG>F  ( n0 n1 -- )
  73   push  TOS
  74   fld   qword [esp]
  75   add   esp,8
  76   pop   TOS
  77   urnext
  78 endcode
  79
  80 ;; drop FP argument from the data stack (can be used for ... functions)
  81 alias 2DROP FPARG-DROP  (  n0 n1 -- )
  82
  83
  84 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  85 vocabulary (dynlib-simple) (hidden) also (dynlib-simple) definitions
  86
  87 ;; `true` means "do not import anything, do it on the first call
  88 true value lazy-creation
  89
  90
  91 ;; for SAVEd images
  92 0 var (last-dynlib)
  93
  94 (* dynlib list item:
  95     dd libhandle
  96     dd previtem-or-0
  97     dd importlist
  98     c1sz libname
  99 *)
 100
 101 (* import list item:
 102     dd procaddr
 103     dd previtem-or-0
 104     dd libitemcfa
 105     db argcount  ;; in cells
 106     db restype   ;; 0: nope; 1: normal; 2: fp (double)
 107     c1sz funcname
 108 *)
 109
 110 0 constant (res-none)
 111 1 constant (res-cell)
 112 2 constant (res-double)
 113
 114 : (dynlib-handle@)  ( dlpfa -- libhandle )  @ ;
 115 : (dynlib-handle!)  ( value dlpfa -- )  ! ;
 116 : (dynlib-prev^)  ( dlpfa -- dlpfa+prevaddrofs )  cell+ ;
 117 : (dynlib-prev@)  ( dlpfa -- prevaddr )  (dynlib-prev^) @ ;
 118 : (dynlib-ilist^)  ( dlpfa -- ilistaddr )  2 +cells ;
 119 : (dynlib-ilist!)  ( value dlpfa -- )  (dynlib-ilist^) ! ;
 120 : (dynlib-ilist@)  ( dlpfa -- ilistaddr )  (dynlib-ilist^) @ ;
 121 : (dynlib-libname@)  ( dlpfa -- addr count )  3 +cells bcount ;
 122
 123 alias cfa->pfa (dynlib-cfa->data)  ( dlcfa -- dlpfa )
 124
 125 : (dynimp-addr@)  ( ilistaddr -- procaddr ) @ ;
 126 : (dynimp-addr!)  ( value ilistaddr -- ) ! ;
 127 : (dynimp-prev^)  ( ilistaddr -- ilistaddr+prevaddrofs ) cell+ ;
 128 : (dynimp-prev@)  ( ilistaddr -- prevaddr ) (dynimp-prev^) @ ;
 129 : (dynimp-libcfa@)  ( ilistaddr -- prevaddr ) 2 +cells @ ;
 130 : (dynimp-argc@)  ( ilistaddr -- argc ) 3 +cells c@ ;
 131 : (dynimp-restype@)  ( ilistaddr -- restype ) 3 +cells 1+ c@ ;
 132 : (dynimp-name@)  ( ilistaddr -- addr count )  3 +cells 2+ bcount ;
 133
 134
 135 : (dynlib-clear-imports)  ( dlpfa -- )
 136   (dynlib-ilist^) begin @ dup while 0 over (dynimp-addr!) (dynimp-prev^) repeat drop
 137 ;
 138
 139 ;; clear all dynlib handles and imports
 140 ..: forth:(startup-init)  ( -- )
 141   (last-dynlib) begin @ ?dup while 0 over (dynlib-handle!) dup (dynlib-clear-imports) (dynlib-prev^) repeat
 142 ;..
 143
 144
 145 : (dynlib-find-by-cfa)  ( cfa -- dlpfa true // false )
 146   (dynlib-cfa->data) (last-dynlib) begin @ ?dup while 2dup = if nip true exit endif (dynlib-prev^) repeat
 147   drop false
 148 ;
 149
 150 : (dynlib-dump-all)  ( -- )
 151   (last-dynlib) begin @ ?dup while
 152     dup (dynlib-libname@) type cr  dup (dynlib-ilist^)
 153     begin @ ?dup while
 154       2 spaces dup (dynimp-addr@) .hex8 space
 155       dup (dynimp-name@) type space
 156       dup (dynimp-argc@) . ." -> "
 157       dup (dynimp-restype@) case
 158         (res-none) of ." void" endof
 159         (res-cell) of ." cell" endof
 160         (res-double) of ." double" endof
 161         otherwise .
 162       endcase
 163       cr
 164     (dynimp-prev^) repeat
 165   (dynlib-prev^) repeat
 166 ; (hidden)
 167
 168
 169 : dynlib:  ( -- )  \ libword oslibpath
 170   create here 0 , ( handle) (last-dynlib) @ , ( link) 0 , ( imports)
 171   parse-name dup 1 250 within not-?abort" invalid lib name"
 172   dup 2+ n-allot dup >r c1s:copy-counted r> c1s:zterm
 173   (last-dynlib) !
 174  does>
 175   dup @ dup ifnot drop  ;; load library
 176       \ ." DLOADING: \'" dup (dynlib-libname@) type ." \'\n"
 177     dup (dynlib-libname@) os:dlopen ?dup ifnot endcr ." FATAL: cannot import dynlib \`" (dynimp-name@) type ." \`\n" 1 n-bye endif
 178     over ! dup (dynlib-clear-imports)
 179     dup @
 180   endif nip
 181 ;
 182
 183
 184 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 185 ;; import syntax:
 186
 187 ;; this creates "XGetModMap" word, imports `XGetModifierMapping`
 188 ;;   [XGetModMap] int XGetModifierMapping( int ); ( dpy -- modmap )
 189 ;;
 190 ;; this creates "XGetModifierMapping" word, imports `XGetModifierMapping`
 191 ;; int XGetModifierMapping( int ); ( dpy -- modmap )
 192
 193 : (dli-custom-name?)  ( addr count -- flag )
 194   dup 2 > if
 195     over c@ [char] < = if
 196       2dup + 1- c@ [char] > = if 2drop true exit endif
 197     endif
 198   endif
 199   2drop false
 200 ; (hidden)
 201
 202 : (dli-import-name?)  ( addr count -- flag )
 203   dup 2 250 within if
 204     dup 1 > if + 1- c@ [char] ( =  ;; )
 205     else 2drop false endif
 206   else 2drop false
 207   endif
 208 ; (hidden)
 209
 210
 211 ;; first two comment chars are not eated
 212 : (dli-interpret-skip-c-multiline)  ( -- )
 213   tib-skipch tib-skipch
 214   begin tib-getch ?dup while [char] * = tib-peekch [char] / = and until tib-skipch
 215 ;
 216
 217 : id-char?  ( ch -- flag )
 218   case
 219     [char] A [char] Z bounds-of true endof
 220     [char] a [char] z bounds-of true endof
 221     [char] 0 [char] 9 bounds-of true endof
 222     [char] _ of true endof
 223     otherwise drop false
 224   endcase
 225 ;
 226
 227 : (dli-interpret-skip-comments)  ( -- )
 228   begin
 229     true parse-skip-comments parse-skip-blanks
 230     tib-peekch case
 231       [char] / of
 232         1 tib-peekch-n [char] * = if (dli-interpret-skip-c-multiline) drop false endif
 233       endof
 234       [char] ( of  ;; )
 235         1 tib-peekch-n bl <= if tib-skipch [char] ) parse 2drop drop false endif
 236       endof
 237       [char] \ of
 238         1 tib-peekch-n bl <= if tib-skipch parse-skip-to-eol drop false endif
 239       endof
 240     endcase
 241   until
 242 ;
 243
 244 : (dli-interpret-next-word)  ( -- addr count )
 245   (dli-interpret-skip-comments)
 246   tib-peekch dup [char] , = over [char] * = or if
 247     drop tib-in^ 1 >in 1+!
 248   else id-char? if
 249     \ parse-name
 250     tib-in^ 0 begin tib-peekch id-char? while 1+ tib-skipch repeat
 251     tib-peekch dup bl > if
 252       dup [char] , = swap [char] * = or ifnot
 253         begin tib-peekch bl > while 1+ tib-skipch repeat
 254       endif
 255     else drop
 256     endif
 257   else parse-name
 258   endif endif
 259     \ endcr ." <" 2dup type ." >\n"
 260 ;
 261
 262 enum{
 263   value (last-type-normal)
 264   value (last-type-fp)
 265   value (last-type-long)
 266   value (last-type-pointer)
 267   value (last-type-signed)
 268   value (last-type-unsigned)
 269 }
 270
 271 -2 constant (no-type)
 272 -1 constant (...-type)
 273
 274 (last-type-normal) value (last-type?)
 275 (no-type) value (type-size)  ;; <0 for special, or cells
 276
 277 : (last-type-fp?)  ( -- flag )  (last-type?) (last-type-fp) = ;
 278 : (last-type-long?)  ( -- flag )  (last-type?) (last-type-long) = ;
 279 : (last-type-sign?)  ( -- flag )  (last-type?) (last-type-signed) (last-type-unsigned) bounds? ;
 280 : (was-type?)  ( -- flag )  (type-size) (no-type) > ;
 281
 282 : (reset-type)  ( -- ) (no-type) to (type-size) ;
 283
 284 : (type-found)  ( size -- )
 285   (was-type?) ?abort" invalid type definition"
 286   to (type-size) (last-type-normal) to (last-type?)
 287 ;
 288
 289 : (simple-type)  ( size -- )  \ name
 290   create c, does> c@ (type-found)
 291 ;
 292
 293 : (float-type)  ( size -- )  \ name
 294   create c, does> c@ (type-found) (last-type-fp) to (last-type?)
 295 ;
 296
 297 vocabulary (dli-types) also (dli-types) definitions
 298 : const  ( -- )  ;
 299
 300 : *  ( -- )
 301   (type-size) 0< ?abort" invalid type definition"
 302   1 to (type-size) (last-type-pointer) to (last-type?)
 303 ;
 304
 305 : int  ( -- )  ;; allow "long int", or a sign
 306   (last-type-sign?) (last-type-long?) or if (reset-type) endif
 307   1 (type-found)
 308 ;
 309
 310 : long  ( -- )  ;; allow "long long", or a sign
 311   (last-type-sign?) if false 1 (reset-type)
 312   else (last-type-long?) if false 2 (reset-type)
 313   else true 1 endif endif
 314   (type-found) if (last-type-long) to (last-type?) endif
 315 ;
 316
 317 : char  ( -- )  ;; allow sign
 318   (last-type-sign?) if (reset-type) endif
 319   1 (type-found)
 320 ;
 321
 322 : signed  ( -- )  1 (type-found) (last-type-signed) to (last-type?) ;
 323 : unsigned  ( -- )  1 (type-found) (last-type-unsigned) to (last-type?) ;
 324
 325 1 (simple-type) size_t
 326 1 (simple-type) ssize_t
 327 0 (simple-type) void
 328
 329 1 (simple-type) int8_t
 330 1 (simple-type) uint8_t
 331 1 (simple-type) int16_t
 332 1 (simple-type) uint16_t
 333 1 (simple-type) int32_t
 334 1 (simple-type) uint32_t
 335 2 (simple-type) int64_t
 336 2 (simple-type) uint64_t
 337
 338 2 (float-type) float  ;; floats are passed as doubles
 339 2 (float-type) double
 340
 341 0 (simple-type) GLvoid
 342 1 (simple-type) GLintptr
 343 1 (simple-type) GLsizei
 344 1 (simple-type) GLchar
 345 1 (simple-type) GLcharARB
 346 1 (simple-type) GLushort
 347 2 (simple-type) GLint64EXT
 348 1 (simple-type) GLshort
 349 2 (simple-type) GLuint64
 350 1 (simple-type) GLhalfARB
 351 1 (simple-type) GLubyte
 352 alias double GLdouble
 353 1 (simple-type) GLhandleARB
 354 2 (simple-type) GLint64
 355 1 (simple-type) GLenum
 356 1 (simple-type) GLeglImageOES  ;; pointer
 357 1 (simple-type) GLintptrARB
 358 1 (simple-type) GLsizeiptr
 359 1 (simple-type) GLint
 360 1 (simple-type) GLboolean
 361 1 (simple-type) GLbitfield
 362 1 (simple-type) GLsizeiptrARB
 363 alias float GLfloat
 364 2 (simple-type) GLuint64EXT
 365 alias float GLclampf
 366 1 (simple-type) GLbyte
 367 alias double GLclampd
 368 1 (simple-type) GLuint
 369 1 (simple-type) GLvdpauSurfaceNV
 370 1 (simple-type) GLfixed
 371 1 (simple-type) GLhalf
 372 1 (simple-type) GLclampx
 373 1 (simple-type) GLhalfNV
 374
 375 : ... ( -- -1 )  (...-type) (type-found) ;
 376 previous definitions
 377
 378 : (dli-parse-type)  ( addr count -- argsize true // false )
 379   (reset-type) (last-type-normal) to (last-type?)
 380   >in @ >r  ;; save "previn"
 381   ;; ( addr count | previn )
 382   begin vocid: (dli-types) voc-search while
 383     execute rdrop >in @ >r (dli-interpret-next-word)
 384   repeat 2drop r> >in !
 385   (was-type?) dup if (type-size) swap endif
 386     \ >in @ (dli-interpret-next-word) endcr ." **<" type >in ! ." >**\n"
 387 ; (hidden)
 388
 389
 390 : (dli-expect-endargs)  ( -- )
 391   (dli-interpret-next-word) 2dup " );" s= not-?abort" `);` expected"
 392 ;
 393
 394 : (dli-parse-args)  ( -- argsize )
 395   0 (dli-interpret-next-word) dup not-?abort" unfinished import declaration"
 396   2dup " );" s= if 2drop
 397   else
 398     begin
 399       (dli-parse-type) not-?abort" unfinished import declaration"
 400       dup ifnot  ;; void -- it should be the only arg here
 401         drop dup ?abort" void argument? wtf?!"
 402         (dli-expect-endargs) break
 403       endif
 404       dup (...-type) = if ( ... ) drop (dli-expect-endargs) break endif
 405       +  (dli-interpret-next-word)
 406       2dup " );" s= ifnot
 407         " ," s= not-?abort" comma expected"
 408         (dli-interpret-next-word) dup not-?abort" unfinished import declaration"
 409         false
 410       else true endif
 411     until 2drop
 412   endif
 413 ;
 414
 415
 416 0 value (dli-cfa)  (hidden)
 417 0 value (dli-pfa)  (hidden)
 418 0 value (dli-handle)  (hidden)
 419
 420 ;; "does>" part of the function, calls the function
 421 ;; imports dynlib and resolves it first if necessary
 422 : (dli-imp-exec)  ( impdata -- )
 423   dup (dynimp-addr@) dup ifnot drop
 424       \ ." IMPORTING: \'" dup (dynimp-name@) type ." \'\n"
 425     dup (dynimp-libcfa@) execute
 426     over (dynimp-name@) rot os:dlsym ?dup ifnot
 427       endcr ." FATAL: symbol \'" dup (dynimp-name@) type ." \' not found in library \'"
 428       (dynimp-libcfa@) (dynlib-cfa->data) (dynlib-libname@) type ." \'\n" 1 n-bye
 429     endif
 430     over (dynimp-addr!) dup (dynimp-addr@)
 431   endif
 432   over (dynimp-restype@) >r swap (dynimp-argc@) os:cinvoke
 433   ;; result
 434   r> case
 435     (res-none) of drop endof
 436     (res-double) of drop F>FPARG endof  ;; fp result
 437   endcase
 438 ; (hidden)
 439
 440
 441 : (dynlib-parse-one-import)  ( addr count -- )
 442   2dup (dli-custom-name?) if  ;; custom-named
 443     /char 1- create-named
 444     (dli-interpret-next-word) true
 445   else false endif
 446   ;; ( taddr tcount createdflag )
 447   >r (dli-parse-type) not-?abort" rettype?"
 448   (last-type-fp?) if 2 = not-?abort" invalid float rettype" (res-double)
 449   else dup 0 1 bounds? not-?abort" invalid rettype" if (res-cell) else (res-none) endif
 450   endif
 451   (dli-interpret-next-word) 2dup (dli-import-name?) not-?abort" import what?" 1-
 452   ;; ( restype naddr ncount | createdflag )
 453   r> ifnot 2dup create-named endif  ;; create a word
 454   (dli-handle) if  ;; immediate import
 455     2dup (dli-handle) os:dlsym ?dup ifnot endcr ." symbol not found: " type abort" import symbol failure" endif
 456   else 0
 457   endif
 458   here    ;; ( restype naddr ncount procaddr here )
 459   swap ,  ;; procaddr
 460   (dli-pfa) (dynlib-ilist@) ,  ;; previtem
 461   (dli-pfa) (dynlib-ilist!)    ;; link
 462   (dli-cfa) ,  ;; libitemcfa
 463   (dli-parse-args) c,  ;; argcount
 464   rot c,  ;; restype
 465   ;; put name
 466   dup 1+ n-allot dup >r c1s:copy-counted r> c1s:zterm
 467   ['] (dli-imp-exec) latest-cfa forth:(!does>) create;
 468 ;
 469
 470 : (dynlib-import-interpret)  ( -- )
 471   begin
 472       \ tib-curr-line . depth . cr
 473     (dli-interpret-next-word) dup while
 474     2dup " end;" s=ci if break endif
 475     ;; must be an import
 476     (dynlib-parse-one-import)
 477   repeat
 478   2drop
 479 ; (hidden)
 480
 481
 482 : dynlib-import:  ( -- dlpfa dlhandle )  \ libname
 483   ' dup (dynlib-find-by-cfa) not-?abort" try to import from a real dynlib next time"
 484   to (dli-pfa) to (dli-cfa)
 485   lazy-creation if 0 else (dli-cfa) execute endif to (dli-handle)
 486   (dynlib-import-interpret)
 487 ;
 488
 489 previous definitions
 490
 491 alias (dynlib-simple):dynlib: dynlib:
 492 alias (dynlib-simple):dynlib-import: dynlib-import:
 493