Annotation of gforth/libcc.fs, revision 1.20

1.1       anton       1: \ libcc.fs     foreign function interface implemented using a C compiler
                      2: 
                      3: \ Copyright (C) 2006 Free Software Foundation, Inc.
                      4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
                      9: \ as published by the Free Software Foundation; either version 2
                     10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
                     18: \ along with this program; if not, write to the Free Software
                     19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
                     20: 
                     21: 
                     22: \ What this implementation does is this: if it sees a declaration like
                     23: 
1.2       anton      24: \ \ something that tells it that the current library is libc
1.6       anton      25: \ \c #include <unistd.h>
1.2       anton      26: \ c-function dlseek lseek n d n -- d
1.1       anton      27: 
                     28: \ it genererates C code similar to the following:
                     29: 
                     30: \ #include <gforth.h>
1.2       anton      31: \ #include <unistd.h>
1.1       anton      32: \ 
1.2       anton      33: \ void gforth_c_lseek_ndn_d(void)
1.1       anton      34: \ {
                     35: \   Cell *sp = gforth_SP;
                     36: \   Float *fp = gforth_FP;
1.2       anton      37: \   long long result;  /* longest type in C */
                     38: \   gforth_ll2d(lseek(sp[3],gforth_d2ll(sp[2],sp[1]),sp[0]),sp[3],sp[2]);
                     39: \   gforth_SP = sp+2;
1.1       anton      40: \ }
                     41: 
                     42: \ Then it compiles this code and dynamically links it into the Gforth
                     43: \ system (batching and caching are future work).  It also dynamically
                     44: \ links lseek.  Performing DLSEEK then puts the function pointer of
1.2       anton      45: \ the function pointer of gforth_c_lseek_ndn_d on the stack and
                     46: \ calls CALL-C.
                     47: 
1.7       anton      48: \ ToDo:
                     49: 
                     50: \ Batching, caching and lazy evaluation:
                     51: 
                     52: \ Batching:
                     53: 
                     54: \ New words are deferred, and the corresponding C functions are
                     55: \ collected in one file, until the first word is EXECUTEd; then the
                     56: \ file is compiled and linked into the system, and the word is
                     57: \ resolved.
                     58: 
                     59: \ Caching:
                     60: 
                     61: \ Instead of compiling all this stuff anew for every execution, we
                     62: \ keep the files around and have an index file containing the function
                     63: \ names and their corresponding .so files.  If the needed wrapper name
                     64: \ is already present, it is just linked instead of generating the
                     65: \ wrapper again.  This is all done by loading the index file(s?),
                     66: \ which define words for the wrappers in a separate wordlist.
                     67: 
                     68: \ The files are built in .../lib/gforth/$VERSION/libcc/ or
                     69: \ ~/.gforth/libcc/$HOST/.
                     70: 
1.2       anton      71: \ other things to do:
                     72: 
                     73: \ c-variable forth-name c-name
                     74: \ c-constant forth-name c-name
                     75: 
1.20    ! anton      76: \ Todo: conversion between function pointers and xts (both directions)
        !            77: 
        !            78: \ taking an xt and turning it into a function pointer:
        !            79: 
        !            80: \ e.g., assume we have the xt of + and want to create a C function int
        !            81: \ gforth_callback_plus(int, int), and then pass the pointer to that
        !            82: \ function:
        !            83: 
        !            84: \ There should be Forth code like this:
        !            85: \   ] + 0 (bye)
        !            86: \ Assume that the start of this code is START
        !            87:         
        !            88: \ Now, there should be a C function:
        !            89: 
        !            90: \ int gforth_callback_plus(int p1, int p2)
        !            91: \ {
        !            92: \   Cell   *sp = gforth_SP;
        !            93: \   Float  *fp = gforth_FP;
        !            94: \   Float  *fp = gforth_FP;
        !            95: \   Address lp = gforth_LP;
        !            96: \   sp -= 2;
        !            97: \   sp[0] = p1;
        !            98: \   sp[1] = p2;
        !            99: \   gforth_engine(START, sp, rp, fp, lp);
        !           100: \   sp += 1;
        !           101: \   gforth_RP = rp;
        !           102: \   gforth_SP = sp;
        !           103: \   gforth_FP = fp;
        !           104: \   gforth_LP = lp;
        !           105: \   return sp[0];
        !           106: \ }
        !           107: 
        !           108: \ and the pointer to that function is the C function pointer for the XT of +.
        !           109: 
        !           110: \ Future problems:
        !           111: \   how to combine the Forth code generation with inlining
        !           112: \   START is not a constant across executions (when caching the C files)
        !           113: \      Solution: make START a variable, and store into it on startup with dlsym
        !           114: 
        !           115: \ Syntax:
        !           116: \  callback <rettype> <params> <paramtypes> -- <rettype>
        !           117: 
1.2       anton     118: 
                    119: \ data structures
                    120: 
1.10      anton     121: \ For every c-function, we have three words: two anonymous words
                    122: \ created by c-function-ft (first time) and c-function-rt (run-time),
                    123: \ and a named deferred word.  The deferred word first points to the
                    124: \ first-time word, then to the run-time word; the run-time word calls
                    125: \ the c function.
                    126: 
1.12      anton     127: 
                    128: require struct.fs
                    129: 
                    130:     \ counted-string
                    131:     
1.10      anton     132: \ c-function-ft word body:
1.12      anton     133: struct
                    134:     cell% field cff-cfr \ xt of c-function-rt word
                    135:     cell% field cff-deferred \ xt of c-function deferred word
                    136:     cell% field cff-lha \ address of the lib-handle for the lib that
                    137:                         \ contains the wrapper function of the word
                    138:     char% field cff-rtype  \ return type
                    139:     char% field cff-np     \ number of parameters
                    140:     1 0   field cff-ptypes \ #npar parameter types
                    141:     \  counted string: c-name
                    142: end-struct cff%
                    143: 
1.14      anton     144: variable c-source-file-id \ contains the source file id of the current batch
                    145: 0 c-source-file-id !
                    146: variable lib-handle-addr \ points to the library handle of the current batch.
                    147:                          \ the library handle is 0 if the current
                    148:                          \ batch is not yet compiled.
1.15      anton     149: 2variable lib-filename \ filename without extension
1.2       anton     150: 
1.3       anton     151: : .nb ( n -- )
1.2       anton     152:     0 .r ;
                    153: 
                    154: : const+ ( n1 "name" -- n2 )
                    155:     dup constant 1+ ;
                    156: 
1.10      anton     157: : front-string { c-addr1 u1 c-addr2 u2 -- c-addr3 u3 }
                    158:     \ insert string c-addr2 u2 in buffer c-addr1 u1; c-addr3 u3 is the
                    159:     \ remainder of the buffer.
                    160:     assert( u1 u2 u>= )
                    161:     c-addr2 c-addr1 u2 move
                    162:     c-addr1 u1 u2 /string ;
                    163: 
                    164: : front-char { c-addr1 u1 c -- c-addr3 u2 }
                    165:     \ insert c in buffer c-addr1 u1; c-addr3 u3 is the remainder of
                    166:     \ the buffer.
                    167:     assert( u1 0 u> )
                    168:     c c-addr1 c!
                    169:     c-addr1 u1 1 /string ;
                    170: 
1.15      anton     171: : s+ { addr1 u1 addr2 u2 -- addr u }
                    172:     u1 u2 + allocate throw { addr }
                    173:     addr1 addr u1 move
                    174:     addr2 addr u1 + u2 move
                    175:     addr u1 u2 +
                    176: ;
                    177: 
                    178: : append { addr1 u1 addr2 u2 -- addr u }
                    179:     addr1 u1 u2 + dup { u } resize throw { addr }
                    180:     addr2 addr u1 + u2 move
                    181:     addr u ;
                    182: 
1.6       anton     183: \ linked list stuff (should go elsewhere)
                    184: 
                    185: struct
                    186:     cell% field list-next
                    187:     1 0   field list-payload
                    188: end-struct list%
                    189: 
                    190: : list-insert { node list -- }
                    191:     list list-next @ node list-next !
                    192:     node list list-next ! ;
                    193: 
                    194: : list-append { node endlistp -- }
                    195:     \ insert node at place pointed to by endlistp
                    196:     node endlistp @ list-insert
                    197:     node list-next endlistp ! ;
                    198: 
                    199: : list-map ( ... list xt -- ... )
                    200:     \ xt ( ... node -- ... )
                    201:     { xt } begin { node }
                    202:        node while
                    203:            node xt execute
                    204:            node list-next @
                    205:     repeat ;
                    206: 
                    207: \ C prefix lines
                    208: 
                    209: \ linked list of longcstrings: [ link | count-cell | characters ]
                    210: 
                    211: list%
                    212:     cell% field c-prefix-count
                    213:     1 0   field c-prefix-chars
                    214: end-struct c-prefix%
                    215: 
                    216: variable c-prefix-lines 0 c-prefix-lines !
                    217: variable c-prefix-lines-end c-prefix-lines c-prefix-lines-end !
                    218: 
1.14      anton     219: : print-c-prefix-line ( node -- )
                    220:     dup c-prefix-chars swap c-prefix-count @ type cr ;
                    221: 
                    222: : print-c-prefix-lines ( -- )
                    223:     c-prefix-lines @ ['] print-c-prefix-line list-map ;
                    224: 
1.6       anton     225: : save-c-prefix-line ( c-addr u -- )
1.14      anton     226:     c-source-file-id @ ?dup-if
                    227:        >r 2dup r> write-line throw
                    228:     then
1.6       anton     229:     align here 0 , c-prefix-lines-end list-append ( c-addr u )
                    230:     longstring, ;
                    231: 
1.18      anton     232: : \c ( "rest-of-line" -- ) \ gforth backslash-c
1.17      anton     233:     \G One line of C declarations for the C interface
1.6       anton     234:     -1 parse save-c-prefix-line ;
                    235: 
1.19      anton     236: s" #include <gforth/" version-string s+ s" /libcc.h>" append ( c-addr u )
                    237:   2dup save-c-prefix-line drop free throw
1.5       anton     238: 
1.6       anton     239: \ Types (for parsing)
1.5       anton     240: 
1.2       anton     241: wordlist constant libcc-types
                    242: 
                    243: get-current libcc-types set-current
                    244: 
                    245: \ index values
                    246: -1
                    247: const+ -- \ end of arguments
                    248: const+ n \ integer cell
1.5       anton     249: const+ a \ address cell
1.2       anton     250: const+ d \ double
                    251: const+ r \ float
                    252: const+ func \ C function pointer
                    253: const+ void
                    254: drop
                    255: 
                    256: set-current
                    257: 
                    258: : parse-libcc-type ( "libcc-type" -- u )
                    259:     parse-name libcc-types search-wordlist 0= -13 and throw execute ;
                    260: 
                    261: : parse-function-types ( "{libcc-type}" "--" "libcc-type" -- )
                    262:     here 2 chars allot here begin
                    263:        parse-libcc-type dup 0>= while
                    264:            c,
                    265:     repeat
1.3       anton     266:     drop here swap - over char+ c!
                    267:     parse-libcc-type dup 0< -32 and throw swap c! ;
1.2       anton     268: 
                    269: : type-letter ( n -- c )
1.5       anton     270:     chars s" nadrfv" drop + c@ ;
1.2       anton     271: 
                    272: \ count-stacks
                    273: 
                    274: : count-stacks-n ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
                    275:     1+ ;
                    276: 
1.5       anton     277: : count-stacks-a ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
1.2       anton     278:     1+ ;
                    279: 
                    280: : count-stacks-d ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
                    281:     2 + ;
                    282: 
                    283: : count-stacks-r ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
                    284:     swap 1+ swap ;
                    285: 
                    286: : count-stacks-func ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
                    287:     1+ ;
                    288: 
                    289: : count-stacks-void ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
                    290: ;
                    291: 
                    292: create count-stacks-types
                    293: ' count-stacks-n ,
1.5       anton     294: ' count-stacks-a ,
1.2       anton     295: ' count-stacks-d ,
                    296: ' count-stacks-r ,
                    297: ' count-stacks-func ,
                    298: ' count-stacks-void ,
                    299: 
                    300: : count-stacks ( pars -- fp-change sp-change )
                    301:     \ pars is an addr u pair
                    302:     0 0 2swap over + swap u+do
1.3       anton     303:        i c@ cells count-stacks-types + @ execute
1.2       anton     304:     loop ;
                    305: 
                    306: \ gen-pars
                    307: 
                    308: : gen-par-n ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
1.5       anton     309:     ." sp[" 1- dup .nb ." ]" ;
1.2       anton     310: 
1.5       anton     311: : gen-par-a ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
1.2       anton     312:     ." (void *)(" gen-par-n ." )" ;
                    313: 
                    314: : gen-par-d ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
1.4       anton     315:     ." gforth_d2ll(" gen-par-n ." ," gen-par-n ." )" ;
1.2       anton     316: 
                    317: : gen-par-r ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
1.3       anton     318:     swap 1- tuck ." fp[" .nb ." ]" ;
1.2       anton     319: 
                    320: : gen-par-func ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
1.5       anton     321:     gen-par-a ;
1.2       anton     322: 
                    323: : gen-par-void ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
                    324:     -32 throw ;
                    325: 
                    326: create gen-par-types
                    327: ' gen-par-n ,
1.5       anton     328: ' gen-par-a ,
1.2       anton     329: ' gen-par-d ,
                    330: ' gen-par-r ,
                    331: ' gen-par-func ,
                    332: ' gen-par-void ,
                    333: 
                    334: : gen-par ( fp-depth1 sp-depth1 partype -- fp-depth2 sp-depth2 )
1.3       anton     335:     cells gen-par-types + @ execute ;
1.2       anton     336: 
                    337: \ the call itself
                    338: 
                    339: : gen-wrapped-call { d: pars d: c-name fp-change1 sp-change1 -- }
                    340:     c-name type ." ("
1.3       anton     341:     fp-change1 sp-change1 pars over + swap u+do 
1.2       anton     342:        i c@ gen-par
                    343:        i 1+ i' < if
                    344:            ." ,"
                    345:        endif
                    346:     loop
                    347:     2drop ." )" ;
                    348: 
                    349: \ calls for various kinds of return values
                    350: 
                    351: : gen-wrapped-void ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
                    352:     2dup 2>r gen-wrapped-call 2r> ;
                    353: 
1.3       anton     354: : gen-wrapped-n ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
1.5       anton     355:     2dup gen-par-n 2>r ." =" gen-wrapped-call 2r> ;
1.3       anton     356: 
1.5       anton     357: : gen-wrapped-a ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
                    358:     2dup gen-par-n 2>r ." =(Cell)" gen-wrapped-call 2r> ;
1.3       anton     359: 
                    360: : gen-wrapped-d ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
                    361:     ." gforth_ll2d(" gen-wrapped-void
1.5       anton     362:     ." ," gen-par-n ." ," gen-par-n ." )" ;
1.3       anton     363: 
                    364: : gen-wrapped-r ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
1.5       anton     365:     2dup gen-par-r 2>r ." =" gen-wrapped-void 2r> ;
1.3       anton     366: 
                    367: : gen-wrapped-func ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
1.5       anton     368:     gen-wrapped-a ;
1.3       anton     369: 
1.2       anton     370: create gen-wrapped-types
                    371: ' gen-wrapped-n ,
1.5       anton     372: ' gen-wrapped-a ,
1.2       anton     373: ' gen-wrapped-d ,
                    374: ' gen-wrapped-r ,
                    375: ' gen-wrapped-func ,
                    376: ' gen-wrapped-void ,
                    377: 
                    378: : gen-wrapped-stmt ( pars c-name fp-change1 sp-change1 ret -- fp-change sp-change )
1.3       anton     379:     cells gen-wrapped-types + @ execute ;
1.2       anton     380: 
1.10      anton     381: : wrapper-function-name ( addr -- c-addr u )
                    382:     \ addr points to the return type index of a c-function descriptor
                    383:     count { r-type } count { d: pars }
                    384:     pars + count { d: c-name }
                    385:     s" gforth_c_" { d: prefix }
                    386:     prefix nip c-name nip + pars nip + 3 + { u }
                    387:     u allocate throw { c-addr }
                    388:     c-addr u
                    389:     prefix front-string c-name front-string '_ front-char
                    390:     pars bounds u+do
                    391:        i c@ type-letter front-char
                    392:     loop
                    393:     '_ front-char r-type type-letter front-char assert( dup 0= )
                    394:     2drop c-addr u ;
                    395: 
1.2       anton     396: : gen-wrapper-function ( addr -- )
                    397:     \ addr points to the return type index of a c-function descriptor
1.10      anton     398:     dup { descriptor }
1.13      anton     399:     count { ret } count 2dup { d: pars } chars + count { d: c-name }
1.10      anton     400:     ." void " descriptor wrapper-function-name 2dup type drop free throw
                    401:     .\" (void)\n"
1.4       anton     402:     .\" {\n  Cell MAYBE_UNUSED *sp = gforth_SP;\n  Float MAYBE_UNUSED *fp = gforth_FP;\n  "
1.2       anton     403:     pars c-name 2over count-stacks ret gen-wrapped-stmt .\" ;\n"
                    404:     ?dup-if
1.3       anton     405:        ."   gforth_SP = sp+" .nb .\" ;\n"
1.2       anton     406:     endif
                    407:     ?dup-if
1.3       anton     408:        ."   gforth_FP = fp+" .nb .\" ;\n"
1.2       anton     409:     endif
1.3       anton     410:     .\" }\n" ;
1.2       anton     411: 
1.16      anton     412: : tempdir ( -- c-addr u )
                    413:     s" TMPDIR" getenv dup 0= if
                    414:         2drop s" /tmp"
                    415:     then ;
                    416: 
1.15      anton     417: : gen-filename ( x -- c-addr u )
                    418:     \ generates a filename without extension for lib-handle-addr X
1.16      anton     419:     0 <<# ['] #s $10 base-execute #> 
                    420:     tempdir s" /gforth-c-" s+ 2swap append #>> ;
1.15      anton     421: 
1.12      anton     422: : init-c-source-file ( -- )
                    423:     c-source-file-id @ 0= if
1.15      anton     424:        here 0 , dup lib-handle-addr ! gen-filename 2dup lib-filename 2!
                    425:        s" .c" s+ 2dup w/o create-file throw dup c-source-file-id !
                    426:         ['] print-c-prefix-lines swap outfile-execute
                    427:         drop free throw
1.12      anton     428:     endif ;
1.11      anton     429: 
                    430: : c-source-file ( -- file-id )
1.12      anton     431:     c-source-file-id @ assert( dup ) ;
1.11      anton     432: 
1.5       anton     433: : compile-wrapper-function ( -- )
1.12      anton     434:     c-source-file close-file throw
                    435:     0 c-source-file-id !
1.19      anton     436:     s" gcc -fPIC -shared -Wl,-soname," lib-filename 2@ s+
1.15      anton     437:     s" .so.1 -Wl,-export_dynamic -o " append lib-filename 2@ append
1.19      anton     438:     [ s" .so.1 -O -I " s" includedir" getenv append s"  " append ] sliteral
                    439:     append lib-filename 2@ append s" .c" append ( c-addr u )
1.15      anton     440:     2dup system drop free throw
                    441:     $? abort" compiler generated error" \ !! call dlerror
1.16      anton     442:     lib-filename 2@ s" .so.1" s+
1.15      anton     443:     2dup open-lib dup 0= abort" open-lib failed" \ !! call dlerror
                    444:     ( lib-handle ) lib-handle-addr @ !
                    445:     2dup delete-file throw drop free throw
                    446:     lib-filename 2@ s" .c" s+ 2dup delete-file throw drop free throw
                    447:     lib-filename 2@ drop free throw 0 0 lib-filename 2! ;
1.5       anton     448: \    s" ar rcs xxx.a xxx.o" system
                    449: \    $? abort" ar generated error" ;
                    450: 
1.12      anton     451: : link-wrapper-function { cff -- sym }
                    452:     cff cff-rtype wrapper-function-name { d: wrapper-name }
                    453:     wrapper-name cff cff-lha @ @ assert( dup ) lib-sym dup 0= -&32 and throw
1.10      anton     454:     wrapper-name drop free throw ;
1.8       anton     455: 
1.12      anton     456: : c-function-ft ( xt-defr xt-cfr "c-name" "{libcc-type}" "--" "libcc-type" -- )
1.8       anton     457:     \ build time/first time action for c-function
1.12      anton     458:     init-c-source-file
                    459:     noname create 2, lib-handle-addr @ ,
1.2       anton     460:     parse-name { d: c-name }
1.8       anton     461:     here parse-function-types c-name string,
1.11      anton     462:     ['] gen-wrapper-function c-source-file outfile-execute
1.8       anton     463:   does> ( ... -- ... )
1.10      anton     464:     dup 2@ { xt-defer xt-cfr }
1.12      anton     465:     dup cff-lha @ @ 0= if
                    466:        compile-wrapper-function
                    467:     endif
                    468:     link-wrapper-function xt-cfr >body !
1.8       anton     469:     xt-cfr xt-defer defer!
                    470:     xt-cfr execute ;
                    471: 
                    472: : c-function-rt ( -- )
                    473:     \ run-time definition for c function; addr is the address where
                    474:     \ the sym should be stored
                    475:     noname create 0 ,
1.2       anton     476:   does> ( ... -- ... )
                    477:     @ call-c ;
                    478: 
1.18      anton     479: : c-function ( "forth-name" "c-name" "@{type@}" "--" "type" -- ) \ gforth
1.17      anton     480:     \G Define a Forth word @i{forth-name}.  @i{Forth-name} has the
                    481:     \G specified stack effect and calls the C function @code{c-name}.
1.8       anton     482:     defer lastxt dup c-function-rt lastxt c-function-ft
                    483:     lastxt swap defer! ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>