fth/flklib.fs

   1 \ FLK "Foreign" language support using shared objects
   2
   3 \ Since the shared objects have to be loaded on startup and closed on shutdown
   4 \ we have to maitain a storage of the libraries. This is done in the words
   5 \ using a linked list which is checked on startup and shutdown. To maintain
   6 \ the correct order of the libraries all declared libraries are appended to
   7 \ the list.
   8
   9 \ Open flags.
  10 1 CONSTANT RTLD_LAZY
  11 2 CONSTANT RTLD_NOW
  12 0x100 CONSTANT RTLD_GLOBAL
  13
  14 \ Head of the library list. The end-of-list pointer is IMAGE-BASE.
  15 IMAGE-BASE RVALUE libraries
  16
  17 \ The tail of the library list.
  18 #? libraries RVALUE last-lib
  19
  20 macro getlib        ( addr len -- lib )
  21   2DUP
  22   RTLD_LAZY RTLD_GLOBAL OR OPENLIB  \ addr len lib
  23   DUP 0= IF
  24     DROP ." Error loading " q-TYPE
  25     ." : " LIBERROR strlen TYPE CR
  26     ABORT
  27   ELSE
  28     -ROT 2DROP
  29   THEN
  30
  31 macro get-symbol      ( lib addr len -- sym )
  32   LIBSYMBOL DUP 0= IF
  33     LIBERROR strlen TYPE CR ABORT
  34   THEN
  35
  36 \ Format of the data area of a library word:
  37 \ offset  meaning
  38 \ 0   last library
  39 \ 1 cell  library handle
  40 macro lib>handle CELL+
  41
  42 \ 2 cells   head of symbol chain
  43 macro lib>sym 8 +
  44
  45 \ 3 cells       filename
  46 macro lib>name 12 +
  47
  48 \ Format of the data area of a symbol word.
  49 \ offset  meaning
  50 \ 0     last lybol
  51 \ 1 cell  fix addr
  52 macro sym>fix CELL+
  53
  54 \ 2 cells   name
  55 macro sym>name 8 +
  56
  57 0 VALUE currentlib
  58 \ Create a named library from the filename given. If the filename is not a
  59 \ global one (i.e. starting with a slash) the default library search path is
  60 \ used. See also: man page of dlopen.
  61 : lib           ( addr len -<name>- )
  62   2DUP getlib CREATE HERE     \ addr len lib link
  63   DUP TO currentlib
  64   ( link into chain )
  65   DUP last-lib !
  66   TO last-lib
  67   IMAGE-BASE r,
  68   ,         \ addr len
  69   IMAGE-BASE r,       \ addr len
  70   ,S
  71   DOES> TO currentlib
  72   ;
  73
  74 ALSO ASSEMBLER
  75 macro (push-param-reg)      ( regs -- )
  76   DUP 0 ?DO         \ regs
  77     req-any
  78   LOOP
  79   DUP 0 ?DO
  80     I (tosn) push,
  81   LOOP
  82   reg-free
  83
  84 macro (push-param-mem)      ( mems -- )
  85   0 ?DO
  86     DWORD offs-ebp [ebp] push,
  87     4 +TO offs-ebp
  88   LOOP
  89
  90 PREVIOUS
  91
  92 macro (link-sym)        ( -- )
  93   currentlib DUP 0=
  94   ABORT" No library declared to load from."
  95   lib>sym DUP @       \ sh lsh
  96   HERE          \ sh lsh here
  97   ROT           \ lsh here sh
  98   !           \ lsh
  99   r,
 100
 101 0 CONSTANT void
 102 1 CONSTANT int
 103 2 CONSTANT double
 104
 105 VOCABULARY C-CALLS
 106 ALSO C-CALLS DEFINITIONS PREVIOUS
 107
 108 ALSO ASSEMBLER
 109 \ Define an integer parameter for the use in a shared library function.
 110 : int           ( n -- n+1 )
 111   regalloc-reset
 112   req-any
 113   tos0 push,
 114   1 reg-free
 115   1+ ;
 116
 117 \ Define some integer parameters for the use in a shared library function.
 118 : ints          ( n ints -- n+1)
 119   regalloc-reset
 120   TUCK #USEREGS MIN DUP     \ ints n regs regs
 121   (push-param-reg)      \ ints n regs
 122   PLUCK SWAP -        \ ints n mems
 123   (push-param-mem)      \ ints n
 124   + ;
 125
 126 \ Define a float parameter for the use in a shared library function.
 127 : float         ( n -- n+1 )
 128   regalloc-reset
 129   req-free
 130   #? FSP #[] free0 mov,
 131   B/FLOAT ## free0 sub,
 132   0 jns,
 133   fstkuflo ## jmp,
 134 0 $:
 135   FSTACK +relocate [free0] fldf,
 136   free0 #? FSP #[] mov,
 137   4 ## esp sub,
 138   esp free0 mov,
 139   0 [free0] fstp32,
 140   1+
 141 ;
 142
 143 \ Define a double parameter for the use in a shared library function.
 144 : double        ( n -- n+1)
 145   regalloc-reset
 146   req-free
 147   req-free
 148   req-free
 149   #? FSP #[] free0 mov,
 150   B/FLOAT ## free0 sub,
 151   0 jns,
 152   fstkuflo ## jmp,
 153 0 $:
 154   FSTACK +relocate [free0] fldf,
 155   free0 #? FSP #[] mov,
 156   8 ## esp sub,
 157   esp free0 mov,
 158   0 [free0] fstp64,
 159   2 +
 160   ;
 161
 162 \ Define an ignored parameter for the use in a shared library function.
 163 : void          ( n -- n )
 164 ;
 165
 166 PREVIOUS DEFINITIONS
 167 ALSO ASSEMBLER
 168 \ Create a word name as a FORTH front end to the library function named
 169 \ libname. returns is one of the constants above and determines the return
 170 \ type of the function.
 171 : fct:          ( returns <name params> -- )
 172   (link-sym)
 173   currentlib lib>handle @
 174   skip-space
 175   >IN @ SWAP        \ ret ind lib
 176   BL PARSE        \ ret ind lib addr len
 177   2DUP 2>R
 178   get-symbol        \ ret ind sym
 179   SWAP >IN !        \ ret sym
 180   :           \ ret sym
 181   regalloc-reset      \ ret sym
 182   DWORD HA-SAVE-F-EBP #[] push,
 183   ALSO C-CALLS
 184   TURN-OFF STATE
 185   0 INTERPRET         \ ret sym cells-esp
 186   TURN-ON STATE
 187   PREVIOUS
 188   regalloc-flushjmp
 189   ebp HA-SAVE-F-EBP #[] mov,
 190   SWAP ## call,       \ ret cells-esp
 191   CHERE r,
 192   2R> ,S        \ ret cesp
 193   DUP IF
 194     CELLS ## esp add,
 195   ELSE
 196     DROP
 197   THEN          \ ret
 198   DWORD HA-SAVE-F-EBP #[] pop,
 199   CASE
 200     int OF
 201       free-eax
 202       0 free>tos
 203     ENDOF
 204     double OF POSTPONE fpush ENDOF
 205   ENDCASE         \
 206   POSTPONE ;
 207   ;
 208 PREVIOUS
 209
 210 \ Create a variable found in lib.
 211 : var:          ( -<name>- )
 212   (link-sym)
 213   currentlib lib>handle @
 214   skip-space
 215   >IN @         \ lib ind
 216   BL PARSE        \ lib ind ln #ln
 217   2DUP 2>R        \ lib ind ln #ln
 218   ROT >IN !  :        \ lib ln #ln
 219   get-symbol        \ sym
 220   POSTPONE LITERAL
 221   CHERE r,
 222   POSTPONE ;
 223   2R> ,S ;
 224
 225 VOCABULARY CB-PARAMS
 226 ALSO CB-PARAMS DEFINITIONS PREVIOUS
 227 ALSO ASSEMBLER
 228
 229 \ Define an integer parameter to be used in a callback function.
 230 : int           ( ind -- ind+1 )
 231   (opt-flush)
 232   regalloc-reset
 233   req-free
 234   esp free0 mov,
 235   DUP CELLS [free0] free0 mov,
 236   0 free>tos
 237   1+
 238 ;
 239
 240 PREVIOUS DEFINITIONS
 241
 242 ALSO ASSEMBLER
 243 \ Define word that's execution semantics can only be used as a callback
 244 \ function. A callback must be ended by ;callback
 245 : callback:         ( returns -<name params>- ret cs)
 246   STATE @ (coding) OR
 247   IF -29 THROW THEN
 248   skip-space
 249   BL PARSE        \ na nl
 250   empty-def?
 251   CHERE         \ na nl xt
 252   -ROT (namedHeader)      \ xt
 253   CFT-callback (new-cs-item)
 254   (curr-cf-item) 3 CELLS + !
 255   0 TO #tos-cache
 256   0 TO offs-ebp
 257   regalloc-reset
 258   ebp push,
 259   HA-SAVE-F-EBP #[] ebp mov,
 260   ebx push,
 261   ecx push,
 262   edx push,
 263   esi push,
 264   edi push,
 265   OVER int <> IF eax push, 8 ELSE 7 THEN
 266   ALSO CB-PARAMS INTERPRET
 267   DROP PREVIOUS       \ ret
 268   (curr-cf-item) 4 CELLS + !
 269   TRUE STATE !
 270   ;
 271
 272 \ End a callback definition.
 273 : ;callback         ( -- )
 274   (opt-flush)
 275   CFT-callback (check-cs-item)
 276   (curr-cf-item) 4 CELLS + @
 277   DUP double = IF POSTPONE fpop THEN
 278   SWAP int = IF
 279     regalloc-flush
 280   ELSE
 281     regalloc-flushjmp
 282     eax pop,
 283   THEN
 284   edi pop,
 285   esi pop,
 286   edx pop,
 287   ecx pop,
 288   ebx pop,
 289   ebp pop,
 290   ret,
 291   FALSE STATE !       \ cs=xt
 292   (curr-cf-item) 3 CELLS + @
 293   >FLAGS        \ ffa
 294   DUP C@ HF-VISIBLE OR SWAP C!
 295   (delete-cs-item)
 296 ; IMMEDIATE
 297 PREVIOUS
 298
 299 \ Get the CFA of a word.
 300 : callback          ( -<name>- )
 301   ' >CFA @ STATE @ IF
 302     POSTPONE RLITERAL
 303   THEN ; IMMEDIATE
 304
 305 \ Correct all symbols in the chain.
 306 : (init-lib-syms)       ( lib sym-dict -- )
 307   BEGIN
 308     DUP IMAGE-BASE <>
 309   WHILE         \ lib sd
 310     DUP sym>name $COUNT     \ lib sd addr len
 311     FLOCK -ROT get-symbol     \ lib sd sym
 312     OVER sym>fix @      \ lib sd sym fix
 313     TUCK - SWAP CELL- !     \ lib sd
 314     @
 315   REPEAT 2DROP ;
 316
 317 \ Load all libraries but not the symbols to be order independed.
 318 : (load-libs)         ( -- )
 319   libraries BEGIN       \ lib-dict
 320     DUP
 321     IMAGE-BASE <>
 322   WHILE         \ lib-dict
 323     DUP lib>name $COUNT     \ lib-dict addr len
 324     getlib        \ lib-dict lib
 325     OVER lib>handle !       \ lib-dict lib
 326     @
 327   REPEAT DROP ;
 328
 329 \ Load all declared symbols from all libraries which have to be loaded
 330 \ already.
 331 : (load-symbols)        ( -- )
 332   libraries BEGIN       \ lib-dict
 333     DUP
 334     IMAGE-BASE <>
 335   WHILE         \ lib-dict
 336     DUP lib>handle @      \ lib-dict lib
 337     OVER lib>sym @ (init-lib-syms)
 338     @
 339   REPEAT DROP ;
 340
 341 \ Load all libraries in the chain and fix their symbols.
 342 : init-lib        ( -- )
 343   in-chain initializer
 344   (load-libs)
 345   (load-symbols)
 346   0 TO currentlib
 347   ;
 348
 349 \ close all libraries in the chain
 350 : done-lib        ( -- )
 351   in-chain finisher
 352   libraries BEGIN
 353     DUP
 354     IMAGE-BASE <>
 355   WHILE         \ lib-dict
 356     DUP lib>handle @ CLOSELIB
 357     @
 358   REPEAT DROP ;
 359
 360 \ Find the first library in the chain below xt and store its address into
 361 \ libraries. All above xt are closed.
 362 : forget-lib        ( xt -- xt )
 363   in-chain forgetter
 364   DUP >DFA @
 365   libraries BEGIN       \ xt lib-dict
 366     2DUP
 367     <=
 368   WHILE         \ lib-dict
 369     DUP lib>handle @ CLOSELIB
 370     @
 371   REPEAT TO libraries DROP ;
 372
 373 ' init-lib TO initializer
 374 ' done-lib TO finisher
 375 ' forget-lib TO forgetter
 376
 377 \ show all loaded libs
 378 : libs          ( -- )
 379   libraries
 380   DUP IMAGE-BASE = IF ." no libs loaded." CR THEN
 381   BEGIN
 382     DUP
 383     IMAGE-BASE <>
 384   WHILE         \ lib-dict
 385     DUP lib>name $COUNT TYPE SPACE
 386     @
 387   REPEAT DROP ;