1/* Part of SWI-Prolog 2 3 Author: Jan Wielemaker 4 E-mail: J.Wielemaker@vu.nl 5 WWW: http://www.swi-prolog.org 6 Copyright (c) 2001-2014, University of Amsterdam, VU University Amsterdam 7 All rights reserved. 8 9 Redistribution and use in source and binary forms, with or without 10 modification, are permitted provided that the following conditions 11 are met: 12 13 1. Redistributions of source code must retain the above copyright 14 notice, this list of conditions and the following disclaimer. 15 16 2. Redistributions in binary form must reproduce the above copyright 17 notice, this list of conditions and the following disclaimer in 18 the documentation and/or other materials provided with the 19 distribution. 20 21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 POSSIBILITY OF SUCH DAMAGE. 33*/ 34 35:- module(qp_foreign, 36 [ load_foreign_files/0, % 37 load_foreign_files/2, % +Files, +Libs 38 load_foreign_files/3, % +Object, +Files, +Libs 39 make_shared_object/3, % +Object, +Files, +Libs 40 make_foreign_wrapper_file/1, % +OutBase 41 make_foreign_wrapper_file/2, % +OFiles, +OutBase 42 % SICStus stuff 43 make_foreign_resource_wrapper/3, % +Resource, +ResBase, +FileBase 44 load_foreign_resource/2 % +Resource, +Dir 45 ]). 46 47:- autoload(library(apply),[exclude/3]). 48:- autoload(library(error),[existence_error/2]). 49:- autoload(library(gensym),[gensym/2]). 50:- autoload(library(lists),[member/2,append/3,select/3]). 51:- autoload(library(shlib),[load_foreign_library/1]).
112:- module_transparent 113 load_foreign_files/0. 114 115:- meta_predicate 116 load_foreign_files( , ), 117 load_foreign_files( , , ), 118 make_shared_object( , , ), 119 make_foreign_wrapper_file( ), 120 make_foreign_wrapper_file( , ), 121 % SICStus 122 make_foreign_resource_wrapper( , , ), 123 load_foreign_resource( , ). 124 125setting(linker, 'swipl-ld'). 126 127hook(M:Goal) :- 128 M:Goal.
132make_wrappers([], _, _). 133make_wrappers([H|T], M, Out) :- 134 make_wrapper(Out, M:H), 135 make_wrappers(T, M, Out).
142make_wrapper(Out, Spec) :- 143 get_foreign_head(Spec, Func, Head), 144 !, 145 ( check_head(Head) 146 -> wrapper_name(Head, WrapName, ArgN), 147 make_C_header(Out, WrapName, ArgN), 148 make_C_decls(Out, Head), 149 make_C_prototype(Out, Head), 150 make_C_input_conversions(Out, Head), 151 make_C_wrapper_setup(Out), 152 make_C_call(Out, Head, Func), 153 make_C_wrapper_check(Out), 154 make_C_output_conversions(Out, Head), 155 make_C_footer(Out) 156 ; fail 157 ). 158make_wrapper(_, Spec) :- 159 existence_error(foreign_declaration, Spec).
167get_foreign_head(M:Function, Function, M:Head) :- 168 prolog_load_context(dialect, sicstus), 169 !, 170 hook(M:foreign(Function, c, Head)). 171get_foreign_head(M:Spec, Func, M:Head) :- 172 ( atom(Spec), 173 hook(M:foreign(Spec, c, Head)), 174 functor(Head, Spec, _) 175 -> true 176 ; Spec = Name/Arity 177 -> functor(Head, Name, Arity), 178 hook(M:foreign(Func, c, Head)) 179 ; Head = Spec, 180 hook(M:foreign(Func, c, Head)) 181 ). 182 183 184check_head(_:Head) :- 185 functor(Head, _, Arity), 186 ( Arity == 0 187 -> true 188 ; arg(_, Head, [-T]), 189 \+ valid_type(T) 190 -> warning('Bad return type ~w in ~w', [T, Head]), 191 fail 192 ; arg(N, Head, [-_T]), 193 N \== Arity 194 -> warning('Return type must be last in ~w', Head), 195 fail 196 ; (arg(_, Head, -T) ; arg(_, Head, +T)), 197 \+ valid_type(T) 198 -> warning('Bad type ~w in ~w', [T, Head]), 199 fail 200 ; true 201 ). 202 203valid_type(int). 204valid_type(integer). 205valid_type(size_t). 206valid_type(float). 207valid_type(single). 208valid_type(string). 209valid_type(chars). % actually, `codes'! 210valid_type(atom). 211valid_type(term). 212valid_type(address). 213valid_type(address(_)).
217cvt_name(chars, _, codes) :- !. 218cvt_name(address(_), _, address) :- !. 219cvt_name(int, o, int64) :- !. 220cvt_name(integer, o, int64) :- !. 221cvt_name(size_t, o, int64) :- !. 222cvt_name(integer, i, long) :- !. 223cvt_name(Type, _, Type).
233make_C_header(Out, WrapName, ArgN) :-
234 format(Out, '~n~nstatic foreign_t~n~w(', [WrapName]),
235 forall(between(1, ArgN, A),
236 ( (A \== 1 -> format(Out, ', ', []) ; true)
237 , arg_name(A, AName),
238 format(Out, 'term_t ~w', [AName])
239 )),
240 format(Out, ')~n{ ', []).
249make_C_decls(Out, _:Head) :- 250 compound(Head), 251 arg(_, Head, [-PlType]), 252 map_C_type(PlType, CType), 253 format(Out, '~wrval;~n ', [CType]), 254 fail. 255make_C_decls(Out, _:Head) :- 256 compound(Head), 257 arg(N, Head, -PlType), 258 arg_name(N, AName), 259 ( PlType == term 260 -> format(Out, 'term_t o_~w = PL_new_term_ref();~n ', [AName]) 261 ; map_C_type(PlType, CType), 262 format(Out, '~wo_~w;~n ', [CType, AName]) 263 ), 264 fail. 265make_C_decls(Out, _:Head) :- 266 compound(Head), 267 arg(N, Head, +PlType), 268 PlType \== term, 269 map_C_type(PlType, CType), 270 CType \== term, 271 arg_name(N, AName), 272 format(Out, '~wi_~w;~n ', [CType, AName]), 273 fail. 274make_C_decls(Out, _) :- 275 format(Out, '~n', []).
282make_C_prototype(Out, M:Head) :- 283 ( compound(Head), 284 arg(_, Head, [-Type]) 285 -> map_C_type(Type, CType) 286 ; CType = 'void ' 287 ), 288 copy_term(Head, H2), % don't bind Head 289 hook(M:foreign(CFunc, c, H2)), 290 !, 291 format(Out, ' extern ~w~w(', [CType, CFunc]), 292 ( compound(Head), 293 arg(N, Head, AType), 294 AType \= [_], % return-type 295 (N > 1 -> format(Out, ', ', []) ; true), 296 ( AType = +T2 297 -> map_C_type(T2, CT2), 298 format(Out, '~w', [CT2]) 299 ; AType == -term 300 -> format(Out, term_t, []) 301 ; AType = -T2 302 -> map_C_type(T2, CT2), 303 format(Out, '~w *', [CT2]) 304 ), 305 fail 306 ; format(Out, ');~n~n', []) 307 ). 308make_C_prototype(_, _).
318make_C_input_conversions(Out, _:Head) :- 319 findall(N-T, (compound(Head),arg(N, Head, +T)), IArgs0), 320 exclude(term_arg, IArgs0, IArgs), 321 ( IArgs == [] 322 -> true 323 ; format(Out, ' if ( ', []), 324 ( member(N-T, IArgs), 325 T \== term, 326 (IArgs \= [N-T|_] -> format(Out, ' ||~n ', []) ; true), 327 arg_name(N, AName), 328 atom_concat(i_, AName, IName), 329 cvt_name(T, i, CVT), 330 format(Out, '!PL_cvt_i_~w(~w, &~w)', [CVT, AName, IName]), 331 fail 332 ; true 333 ), 334 format(Out, ' )~n return FALSE;~n~n', []) 335 ). 336 337term_arg(_-term).
346make_C_call(Out, _:Head, CFunc) :- 347 ( compound(Head), 348 arg(_, Head, [-_]) 349 -> format(Out, ' rval = ~w(', [CFunc]) 350 ; format(Out, ' (void) ~w(', [CFunc]) 351 ), 352 compound(Head), 353 arg(N, Head, Arg), 354 Arg \= [_], 355 (N \== 1 -> format(Out, ', ', []) ; true), 356 arg_name(N, AName), 357 ( Arg = -term 358 -> format(Out, 'o_~w', [AName]) 359 ; Arg = -_ 360 -> format(Out, '&o_~w', [AName]) 361 ; Arg = +term 362 -> format(Out, '~w', [AName]) 363 ; format(Out, 'i_~w', [AName]) 364 ), 365 fail. 366make_C_call(Out, _, _) :- 367 format(Out, ');~n', []).
374make_C_wrapper_setup(Stream) :- 375 prolog_load_context(dialect, sicstus), 376 !, 377 format(Stream, ' SP_WRAP_INIT();~n', []). 378make_C_wrapper_setup(_).
386make_C_wrapper_check(Stream) :- 387 prolog_load_context(dialect, sicstus), 388 !, 389 format(Stream, ' SP_WRAP_CHECK_STATE();~n', []). 390make_C_wrapper_check(_).
398make_C_output_conversions(Out, _:Head) :- 399 findall(N-T, (compound(Head),arg(N, Head, -T)), OArgs0), 400 ( compound(Head), 401 arg(_, Head, [-RT]) 402 -> OArgs = [rval-RT|OArgs0] 403 ; OArgs = OArgs0 404 ), 405 ( OArgs == [] 406 -> true 407 ; format(Out, '~n if ( ', []), 408 ( member(N-T, OArgs), 409 ( N == rval 410 -> OName = rval, 411 arg(RN, Head, [-_]), 412 arg_name(RN, AName) 413 ; arg_name(N, AName), 414 atom_concat(o_, AName, OName) 415 ), 416 (OArgs = [N-T|_] -> true ; format(Out, ' ||~n ', [])), 417 ( T == term 418 -> format(Out, '!PL_unify(~w, ~w)', [OName, AName]) 419 ; cvt_name(T, o, CVT), 420 format(Out, '!PL_cvt_o_~w(~w, ~w)', [CVT, OName, AName]) 421 ), 422 fail 423 ; true 424 ), 425 format(Out, ' )~n return FALSE;~n', []) 426 ). 427 428 Out) (:- 430 format(Out, '~n return TRUE;~n}~n', []). 431 432 /******************************* 433 * INIT STATEMENT * 434 *******************************/
Of the supported PL_FA_<FLAGS>, TRANSPARENT may be declared by looking at the transparent (meta_predivate) attribute of the predicate.
446make_C_init(Out, InstallFunc, Init, M, Preds) :- 447 format(Out, '~n~nstatic PL_extension predicates [] =~n{~n', []), 448 format(Out, '/*{ "name", arity, function, PL_FA_<flags> },*/~n', []), 449 ( member(Pred, Preds), 450 get_foreign_head(M:Pred, _Func, Head), 451 Head = M:H, 452 functor(H, Name, Arity), 453 wrapper_name(Head, Wrapper, Arity), 454 foreign_attributes(M:H, Atts), 455 format(Out, ' { "~w", ~d, ~w, ~w },~n', 456 [Name, Arity, Wrapper, Atts]), 457 fail 458 ; true 459 ), 460 format(Out, ' { NULL, 0, NULL, 0 } /* terminator */~n};~n~n', []), 461 format(Out, 'install_t~n~w()~n{ PL_load_extensions(predicates);~n', 462 [InstallFunc]), 463 sicstus_init_function(Out, Init), 464 format(Out, '}~n', []). 465 466sicstus_init_function(_, -) :- !. 467sicstus_init_function(Out, Init) :- 468 format(Out, ' extern void ~w(int);~n', [Init]), 469 format(Out, ' ~w(0);~n', [Init]). 470 471foreign_attributes(Head, Atts) :- 472 findall(A, foreign_attribute(Head, A), A0), 473 ( A0 == [] 474 -> Atts = 0 475 ; atomic_list_concat(A0, '|', Atts) 476 ). 477 478foreign_attribute(Head, 'PL_FA_TRANSPARENT') :- 479 predicate_property(Head, transparent).
485make_C_deinit(_, _, -) :- !. 486make_C_deinit(Out, Func, DeInit) :- 487 format(Out, '~ninstall_t~n', []), 488 format(Out, '~w()~n', [Func]), 489 format(Out, '{ extern void ~w(int);~n', [DeInit]), 490 format(Out, ' ~w(0);~n', [DeInit]), 491 format(Out, '}~n', []).
498make_C_file_header(Out) :- 499 current_prolog_flag(version_data, swi(Major, Minor, Patch, _)), 500 get_time(Time), 501 format_time(string(When), '%F %H:%M', Time), 502 format(Out, '/* SWI-Prolog link wrapper~n', []), 503 format(Out, ' Generated by SWI-Prolog version ~w.~w.~w~n', 504 [Major, Minor, Patch]), 505 format(Out, ' At ~s~n', [When]), 506 ( source_location(File, Line) 507 -> format(Out, ' Source context ~w:~d~n', [File, Line]) 508 ; true 509 ), 510 format(Out, '*/~n~n', []), 511 format(Out, '#include <SWI-Prolog.h>~n', []), 512 make_C_compat_file_header(Out), 513 format(Out, '#ifndef NULL~n', []), 514 format(Out, '#define NULL ((void *)0)~n', []), 515 format(Out, '#endif~n~n', []). 516 517 518make_C_compat_file_header(Out) :- 519 prolog_load_context(dialect, sicstus), 520 !, 521 format(Out, '#define SP_WRAPPER 1~n', []), 522 format(Out, '#include <sicstus/sicstus.h>~n', []). 523make_C_compat_file_header(_). 524 525 526 /******************************* 527 * TOPLEVEL * 528 *******************************/
make_foreign_wrapper_file(+File)
, compiles the wrapper
and loads the predicates.537load_foreign_files :- 538 context_module(M), 539 findall(File, hook(M:foreign_file(File, _)), OFiles), 540 load_foreign_files(M:OFiles, []). 541load_foreign_files(OFiles, Libs) :- 542 gensym(link, LinkBase), 543 load_foreign_files(LinkBase, OFiles, Libs). 544 545load_foreign_files(LinkBase, M:_, _) :- 546 catch(load_foreign_library(M:LinkBase), _, fail), 547 !. 548load_foreign_files(LinkBase, OFiles, Libs) :- 549 make_shared_object(LinkBase, OFiles, Libs), 550 OFiles = M:_List, 551 load_foreign_library(M:LinkBase).
558make_shared_object(LinkBase, M:OFiles, Libs) :-
559 make_foreign_wrapper_file(M:OFiles, LinkBase),
560 file_name_extension(LinkBase, c, CFile),
561 build_shared_object(LinkBase, [CFile|OFiles], Libs).
570make_foreign_wrapper_file(M:CFile) :- 571 findall(File, hook(M:foreign_file(File, _)), OFiles), 572 make_foreign_wrapper_file(M:OFiles, CFile). 573make_foreign_wrapper_file(M:OFiles, Base) :- 574 file_name_extension(Base, c, CFile), 575 file_base_name(Base, FuncBase), 576 atom_concat(install_, FuncBase, InstallFunc), 577 collect_foreign_predicates(OFiles, M, Preds), 578 open(CFile, write, Out), 579 make_C_file_header(Out), 580 make_wrappers(Preds, M, Out), 581 make_C_init(Out, InstallFunc, -, M, Preds), 582 close(Out). 583 584 585collect_foreign_predicates([], _, []). 586collect_foreign_predicates([File|Files], M, Preds) :- 587 hook(M:foreign_file(File, P0)), 588 collect_foreign_predicates(Files, M, P1), 589 append(P0, P1, Preds). 590 Object, Files, Libs) (:- 592 current_prolog_flag(shared_object_extension, Ext), 593 file_name_extension(Object, Ext, SharedObject), 594 append(Files, Libs, Input), 595 atomic_list_concat(Input, ' ', InputAtom), 596 setting(linker, Linker), 597 format(string(Command), 598 '~w -shared -o ~w ~w', [Linker, SharedObject, InputAtom]), 599 shell(Command). 600 601 602 /******************************* 603 * SICSTUS * 604 *******************************/
610make_foreign_resource_wrapper(M:Resource, ResBase, FileBase) :- 611 hook(M:foreign_resource(Resource, Functions)), 612 take(init(Init), Functions, Functions1, -), 613 take(deinit(DeInit), Functions1, Preds, -), 614 file_name_extension(FileBase, c, CFile), 615 file_base_name(ResBase, FuncBase), 616 atom_concat(install_, FuncBase, InstallFunc), 617 atom_concat(uninstall_, FuncBase, UninstallFunc), 618 open(CFile, write, Out), 619 make_C_file_header(Out), 620 make_wrappers(Preds, M, Out), 621 make_C_init(Out, InstallFunc, Init, M, Preds), 622 make_C_deinit(Out, UninstallFunc, DeInit), 623 close(Out). 624 625take(Term, List, Rest, Default) :- 626 ( select(Term, List, Rest) 627 -> true 628 ; arg(1, Term, Default), 629 Rest = List 630 ).
639load_foreign_resource(M:Resource, Source) :- 640 absolute_file_name(Resource, Object, 641 [ file_type(executable), 642 relative_to(Source), 643 file_errors(fail) 644 ]), 645 !, 646 load_foreign_library(M:Object). 647load_foreign_resource(M:Resource, _) :- 648 load_foreign_library(M:foreign(Resource)). 649 650 651 /******************************* 652 * UTIL * 653 *******************************/ 654 655arg_name(N, Name) :- 656 C is N + 0'a - 1, 657 atom_codes(Name, [C]). 658 659wrapper_name(_:Head, Wrapper, Arity) :- 660 functor(Head, Name, Arity), 661 atomic_list_concat(['_plw_', Name, Arity], Wrapper).
667map_C_type(X, Y) :- 668 map_C_type_(X, Y), 669 !. 670map_C_type(X, X). 671 672map_C_type_(int, 'int '). 673map_C_type_(integer, 'long '). 674map_C_type_(size_t, 'size_t '). 675map_C_type_(float, 'double '). 676map_C_type_(string, 'char *'). 677map_C_type_(chars, 'char *'). 678map_C_type_(address, 'void *'). 679map_C_type_(address(Of), Type) :- 680 atom_concat(Of, ' *', Type). 681map_C_type_(term, 'term_t '). 682 683warning(Fmt, Args) :- 684 print_message(warning, format(Fmt, Args)). 685 686 687 /******************************* 688 * XREF * 689 *******************************/ 690 691:- multifile 692 prolog:hook/1. 693 694prologhook(foreign(_,_,_)). 695prologhook(foreign_resource(_,_))
Quintus compatible foreign loader
This module defines a Quintus compatible foreign language interface based on the foreign_file/2 and foreign/3 declarations.
Predicates:
Example:
Supported types:
NOTE This modules requires a correctly functioning swipl-ld and load_foreign_library/1 on your system. If this isn't the case use make_foreign_wrapper_file/[1,2] to generate a wrapper and use static embedding.