diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Henning Thielemann 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/data/blas.csv b/data/blas.csv new file mode 100644 --- /dev/null +++ b/data/blas.csv @@ -0,0 +1,58 @@ +Name,Float,Double,ComplexFloat,ComplexDouble,Miscellaneous +asum,sasum.f,dasum.f,,, +axpy,saxpy.f,daxpy.f,caxpy.f,zaxpy.f, +cabs1,,,scabs1.f,dcabs1.f, +casum,,,scasum.f,dzasum.f, +cnrm2,,,scnrm2.f,dznrm2.f, +copy,scopy.f,dcopy.f,ccopy.f,zcopy.f, +dot,sdot.f,ddot.f,,, +dotc,,,cdotc.f,zdotc.f, +dotu,,,cdotu.f,zdotu.f, +dsdot,sdsdot.f,,,, +gbmv,sgbmv.f,dgbmv.f,cgbmv.f,zgbmv.f, +gemm,sgemm.f,dgemm.f,cgemm.f,zgemm.f, +gemv,sgemv.f,dgemv.f,cgemv.f,zgemv.f, +ger,sger.f,dger.f,,, +gerc,,,cgerc.f,zgerc.f, +geru,,,cgeru.f,zgeru.f, +hbmv,,,chbmv.f,zhbmv.f, +hemm,,,chemm.f,zhemm.f, +hemv,,,chemv.f,zhemv.f, +her,,,cher.f,zher.f, +her2,,,cher2.f,zher2.f, +her2k,,,cher2k.f,zher2k.f, +herk,,,cherk.f,zherk.f, +hpmv,,,chpmv.f,zhpmv.f, +hpr,,,chpr.f,zhpr.f, +hpr2,,,chpr2.f,zhpr2.f, +iamax,isamax.f,idamax.f,icamax.f,izamax.f, +nrm2,snrm2.f,dnrm2.f,,, +rot,srot.f,drot.f,,, +rotg,srotg.f,drotg.f,crotg.f,zrotg.f, +rotm,srotm.f,drotm.f,,, +rotmg,srotmg.f,drotmg.f,,, +rrot,,,csrot.f,zdrot.f, +rscal,,,csscal.f,zdscal.f, +sbmv,ssbmv.f,dsbmv.f,,, +scal,sscal.f,dscal.f,cscal.f,zscal.f, +sdot,,dsdot.f,,, +spmv,sspmv.f,dspmv.f,,, +spr,sspr.f,dspr.f,,, +spr2,sspr2.f,dspr2.f,,, +swap,sswap.f,dswap.f,cswap.f,zswap.f, +symm,ssymm.f,dsymm.f,csymm.f,zsymm.f, +symv,ssymv.f,dsymv.f,,, +syr,ssyr.f,dsyr.f,,, +syr2,ssyr2.f,dsyr2.f,,, +syr2k,ssyr2k.f,dsyr2k.f,csyr2k.f,zsyr2k.f, +syrk,ssyrk.f,dsyrk.f,csyrk.f,zsyrk.f, +tbmv,stbmv.f,dtbmv.f,ctbmv.f,ztbmv.f, +tbsv,stbsv.f,dtbsv.f,ctbsv.f,ztbsv.f, +tpmv,stpmv.f,dtpmv.f,ctpmv.f,ztpmv.f, +tpsv,stpsv.f,dtpsv.f,ctpsv.f,ztpsv.f, +trmm,strmm.f,dtrmm.f,ctrmm.f,ztrmm.f, +trmv,strmv.f,dtrmv.f,ctrmv.f,ztrmv.f, +trsm,strsm.f,dtrsm.f,ctrsm.f,ztrsm.f, +trsv,strsv.f,dtrsv.f,ctrsv.f,ztrsv.f, +lsame,,,,,lsame.f +xerbla,,,,,xerbla.f diff --git a/data/lapack.csv b/data/lapack.csv new file mode 100644 --- /dev/null +++ b/data/lapack.csv @@ -0,0 +1,493 @@ +Name,Float,Double,ComplexFloat,ComplexDouble,Miscellaneous +bbcsd,sbbcsd.f,dbbcsd.f,cbbcsd.f,zbbcsd.f, +bdsdc,sbdsdc.f,dbdsdc.f,,, +bdsqr,sbdsqr.f,dbdsqr.f,cbdsqr.f,zbdsqr.f, +cgesv,,,,zcgesv.f, +cposv,,,,zcposv.f, +disna,sdisna.f,ddisna.f,,, +gbbrd,sgbbrd.f,dgbbrd.f,cgbbrd.f,zgbbrd.f, +gbcon,sgbcon.f,dgbcon.f,cgbcon.f,zgbcon.f, +gbequ,sgbequ.f,dgbequ.f,cgbequ.f,zgbequ.f, +gbequb,sgbequb.f,dgbequb.f,cgbequb.f,zgbequb.f, +gbrfs,sgbrfs.f,dgbrfs.f,cgbrfs.f,zgbrfs.f, +gbsv,sgbsv.f,dgbsv.f,cgbsv.f,zgbsv.f, +gbsvx,sgbsvx.f,dgbsvx.f,cgbsvx.f,zgbsvx.f, +gbtf2,sgbtf2.f,dgbtf2.f,cgbtf2.f,zgbtf2.f, +gbtrf,sgbtrf.f,dgbtrf.f,cgbtrf.f,zgbtrf.f, +gbtrs,sgbtrs.f,dgbtrs.f,cgbtrs.f,zgbtrs.f, +gebak,sgebak.f,dgebak.f,cgebak.f,zgebak.f, +gebal,sgebal.f,dgebal.f,cgebal.f,zgebal.f, +gebd2,sgebd2.f,dgebd2.f,cgebd2.f,zgebd2.f, +gebrd,sgebrd.f,dgebrd.f,cgebrd.f,zgebrd.f, +gecon,sgecon.f,dgecon.f,cgecon.f,zgecon.f, +geequ,sgeequ.f,dgeequ.f,cgeequ.f,zgeequ.f, +geequb,sgeequb.f,dgeequb.f,cgeequb.f,zgeequb.f, +gees,sgees.f,dgees.f,cgees.f,zgees.f, +geesx,sgeesx.f,dgeesx.f,cgeesx.f,zgeesx.f, +geev,sgeev.f,dgeev.f,cgeev.f,zgeev.f, +geevx,sgeevx.f,dgeevx.f,cgeevx.f,zgeevx.f, +gehd2,sgehd2.f,dgehd2.f,cgehd2.f,zgehd2.f, +gehrd,sgehrd.f,dgehrd.f,cgehrd.f,zgehrd.f, +gejsv,sgejsv.f,dgejsv.f,,, +gelq2,sgelq2.f,dgelq2.f,cgelq2.f,zgelq2.f, +gelqf,sgelqf.f,dgelqf.f,cgelqf.f,zgelqf.f, +gels,sgels.f,dgels.f,cgels.f,zgels.f, +gelsd,sgelsd.f,dgelsd.f,cgelsd.f,zgelsd.f, +gelss,sgelss.f,dgelss.f,cgelss.f,zgelss.f, +gelsy,sgelsy.f,dgelsy.f,cgelsy.f,zgelsy.f, +geql2,sgeql2.f,dgeql2.f,cgeql2.f,zgeql2.f, +geqlf,sgeqlf.f,dgeqlf.f,cgeqlf.f,zgeqlf.f, +geqp3,sgeqp3.f,dgeqp3.f,cgeqp3.f,zgeqp3.f, +geqr2,sgeqr2.f,dgeqr2.f,cgeqr2.f,zgeqr2.f, +geqr2p,sgeqr2p.f,dgeqr2p.f,cgeqr2p.f,zgeqr2p.f, +geqrf,sgeqrf.f,dgeqrf.f,cgeqrf.f,zgeqrf.f, +geqrfp,sgeqrfp.f,dgeqrfp.f,cgeqrfp.f,zgeqrfp.f, +gerfs,sgerfs.f,dgerfs.f,cgerfs.f,zgerfs.f, +gerq2,sgerq2.f,dgerq2.f,cgerq2.f,zgerq2.f, +gerqf,sgerqf.f,dgerqf.f,cgerqf.f,zgerqf.f, +gesc2,sgesc2.f,dgesc2.f,cgesc2.f,zgesc2.f, +gesdd,sgesdd.f,dgesdd.f,cgesdd.f,zgesdd.f, +gesv,sgesv.f,dgesv.f,cgesv.f,zgesv.f, +gesvd,sgesvd.f,dgesvd.f,cgesvd.f,zgesvd.f, +gesvj,sgesvj.f,dgesvj.f,,, +gesvx,sgesvx.f,dgesvx.f,cgesvx.f,zgesvx.f, +getc2,sgetc2.f,dgetc2.f,cgetc2.f,zgetc2.f, +getf2,sgetf2.f,dgetf2.f,cgetf2.f,zgetf2.f, +getrf,sgetrf.f,dgetrf.f,cgetrf.f,zgetrf.f, +getri,sgetri.f,dgetri.f,cgetri.f,zgetri.f, +getrs,sgetrs.f,dgetrs.f,cgetrs.f,zgetrs.f, +ggbak,sggbak.f,dggbak.f,cggbak.f,zggbak.f, +ggbal,sggbal.f,dggbal.f,cggbal.f,zggbal.f, +gges,sgges.f,dgges.f,cgges.f,zgges.f, +ggesx,sggesx.f,dggesx.f,cggesx.f,zggesx.f, +ggev,sggev.f,dggev.f,cggev.f,zggev.f, +ggevx,sggevx.f,dggevx.f,cggevx.f,zggevx.f, +ggglm,sggglm.f,dggglm.f,cggglm.f,zggglm.f, +gghrd,sgghrd.f,dgghrd.f,cgghrd.f,zgghrd.f, +gglse,sgglse.f,dgglse.f,cgglse.f,zgglse.f, +ggqrf,sggqrf.f,dggqrf.f,cggqrf.f,zggqrf.f, +ggrqf,sggrqf.f,dggrqf.f,cggrqf.f,zggrqf.f, +gsvj0,sgsvj0.f,dgsvj0.f,,, +gsvj1,sgsvj1.f,dgsvj1.f,,, +gtcon,sgtcon.f,dgtcon.f,cgtcon.f,zgtcon.f, +gtrfs,sgtrfs.f,dgtrfs.f,cgtrfs.f,zgtrfs.f, +gtsv,sgtsv.f,dgtsv.f,cgtsv.f,zgtsv.f, +gtsvx,sgtsvx.f,dgtsvx.f,cgtsvx.f,zgtsvx.f, +gttrf,sgttrf.f,dgttrf.f,cgttrf.f,zgttrf.f, +gttrs,sgttrs.f,dgttrs.f,cgttrs.f,zgttrs.f, +gtts2,sgtts2.f,dgtts2.f,cgtts2.f,zgtts2.f, +hbev,,,chbev.f,zhbev.f, +hbevd,,,chbevd.f,zhbevd.f, +hbevx,,,chbevx.f,zhbevx.f, +hbgst,,,chbgst.f,zhbgst.f, +hbgv,,,chbgv.f,zhbgv.f, +hbgvd,,,chbgvd.f,zhbgvd.f, +hbgvx,,,chbgvx.f,zhbgvx.f, +hbtrd,,,chbtrd.f,zhbtrd.f, +hecon,,,checon.f,zhecon.f, +heequb,,,cheequb.f,zheequb.f, +heev,,,cheev.f,zheev.f, +heevd,,,cheevd.f,zheevd.f, +heevr,,,cheevr.f,zheevr.f, +heevx,,,cheevx.f,zheevx.f, +hegs2,,,chegs2.f,zhegs2.f, +hegst,,,chegst.f,zhegst.f, +hegv,,,chegv.f,zhegv.f, +hegvd,,,chegvd.f,zhegvd.f, +hegvx,,,chegvx.f,zhegvx.f, +herfs,,,cherfs.f,zherfs.f, +hesv,,,chesv.f,zhesv.f, +hesvx,,,chesvx.f,zhesvx.f, +heswapr,,,cheswapr.f,zheswapr.f, +hetd2,,,chetd2.f,zhetd2.f, +hetf2,,,chetf2.f,zhetf2.f, +hetrd,,,chetrd.f,zhetrd.f, +hetrf,,,chetrf.f,zhetrf.f, +hetri,,,chetri.f,zhetri.f, +hetri2,,,chetri2.f,zhetri2.f, +hetri2x,,,chetri2x.f,zhetri2x.f, +hetrs,,,chetrs.f,zhetrs.f, +hetrs2,,,chetrs2.f,zhetrs2.f, +hfrk,,,chfrk.f,zhfrk.f, +hgeqz,shgeqz.f,dhgeqz.f,chgeqz.f,zhgeqz.f, +hpcon,,,chpcon.f,zhpcon.f, +hpev,,,chpev.f,zhpev.f, +hpevd,,,chpevd.f,zhpevd.f, +hpevx,,,chpevx.f,zhpevx.f, +hpgst,,,chpgst.f,zhpgst.f, +hpgv,,,chpgv.f,zhpgv.f, +hpgvd,,,chpgvd.f,zhpgvd.f, +hpgvx,,,chpgvx.f,zhpgvx.f, +hprfs,,,chprfs.f,zhprfs.f, +hpsv,,,chpsv.f,zhpsv.f, +hpsvx,,,chpsvx.f,zhpsvx.f, +hptrd,,,chptrd.f,zhptrd.f, +hptrf,,,chptrf.f,zhptrf.f, +hptri,,,chptri.f,zhptri.f, +hptrs,,,chptrs.f,zhptrs.f, +hsein,shsein.f,dhsein.f,chsein.f,zhsein.f, +hseqr,shseqr.f,dhseqr.f,chseqr.f,zhseqr.f, +ilalc,ilaslc.f,iladlc.f,ilaclc.f,ilazlc.f, +ilalr,ilaslr.f,iladlr.f,ilaclr.f,ilazlr.f, +imax1,,,icmax1.f,izmax1.f, +isnan,sisnan.f,disnan.f,,, +labad,slabad.f,dlabad.f,,, +labrd,slabrd.f,dlabrd.f,clabrd.f,zlabrd.f, +lacgv,,,clacgv.f,zlacgv.f, +lacn2,slacn2.f,dlacn2.f,clacn2.f,zlacn2.f, +lacon,slacon.f,dlacon.f,clacon.f,zlacon.f, +lacp2,,,clacp2.f,zlacp2.f, +lacpy,slacpy.f,dlacpy.f,clacpy.f,zlacpy.f, +lacrm,,,clacrm.f,zlacrm.f, +lacrt,,,clacrt.f,zlacrt.f, +ladiv,sladiv.f,dladiv.f,cladiv.f,zladiv.f, +lae2,slae2.f,dlae2.f,,, +laebz,slaebz.f,dlaebz.f,,, +laed0,slaed0.f,dlaed0.f,claed0.f,zlaed0.f, +laed1,slaed1.f,dlaed1.f,,, +laed2,slaed2.f,dlaed2.f,,, +laed3,slaed3.f,dlaed3.f,,, +laed4,slaed4.f,dlaed4.f,,, +laed5,slaed5.f,dlaed5.f,,, +laed6,slaed6.f,dlaed6.f,,, +laed7,slaed7.f,dlaed7.f,claed7.f,zlaed7.f, +laed8,slaed8.f,dlaed8.f,claed8.f,zlaed8.f, +laed9,slaed9.f,dlaed9.f,,, +laeda,slaeda.f,dlaeda.f,,, +laein,slaein.f,dlaein.f,claein.f,zlaein.f, +laesy,,,claesy.f,zlaesy.f, +laev2,slaev2.f,dlaev2.f,claev2.f,zlaev2.f, +laexc,slaexc.f,dlaexc.f,,, +lag2,slag2.f,dlag2.f,,, +lag2c,,,,zlag2c.f, +lag2d,slag2d.f,,,, +lag2s,,dlag2s.f,,, +lag2z,,,clag2z.f,, +lags2,slags2.f,dlags2.f,clags2.f,zlags2.f, +lagtf,slagtf.f,dlagtf.f,,, +lagtm,slagtm.f,dlagtm.f,clagtm.f,zlagtm.f, +lagts,slagts.f,dlagts.f,,, +lagv2,slagv2.f,dlagv2.f,,, +lahef,,,clahef.f,zlahef.f, +lahqr,slahqr.f,dlahqr.f,clahqr.f,zlahqr.f, +lahr2,slahr2.f,dlahr2.f,clahr2.f,zlahr2.f, +laic1,slaic1.f,dlaic1.f,claic1.f,zlaic1.f, +laisnan,slaisnan.f,dlaisnan.f,,, +laln2,slaln2.f,dlaln2.f,,, +lals0,slals0.f,dlals0.f,clals0.f,zlals0.f, +lalsa,slalsa.f,dlalsa.f,clalsa.f,zlalsa.f, +lalsd,slalsd.f,dlalsd.f,clalsd.f,zlalsd.f, +lamrg,slamrg.f,dlamrg.f,,, +laneg,slaneg.f,dlaneg.f,,, +langb,slangb.f,dlangb.f,clangb.f,zlangb.f, +lange,slange.f,dlange.f,clange.f,zlange.f, +langt,slangt.f,dlangt.f,clangt.f,zlangt.f, +lanhb,,,clanhb.f,zlanhb.f, +lanhe,,,clanhe.f,zlanhe.f, +lanhf,,,clanhf.f,zlanhf.f, +lanhp,,,clanhp.f,zlanhp.f, +lanhs,slanhs.f,dlanhs.f,clanhs.f,zlanhs.f, +lanht,,,clanht.f,zlanht.f, +lansb,slansb.f,dlansb.f,clansb.f,zlansb.f, +lansf,slansf.f,dlansf.f,,, +lansp,slansp.f,dlansp.f,clansp.f,zlansp.f, +lanst,slanst.f,dlanst.f,,, +lansy,slansy.f,dlansy.f,clansy.f,zlansy.f, +lantb,slantb.f,dlantb.f,clantb.f,zlantb.f, +lantp,slantp.f,dlantp.f,clantp.f,zlantp.f, +lantr,slantr.f,dlantr.f,clantr.f,zlantr.f, +lanv2,slanv2.f,dlanv2.f,,, +lapll,slapll.f,dlapll.f,clapll.f,zlapll.f, +lapmr,slapmr.f,dlapmr.f,clapmr.f,zlapmr.f, +lapmt,slapmt.f,dlapmt.f,clapmt.f,zlapmt.f, +lapy2,slapy2.f,dlapy2.f,,, +lapy3,slapy3.f,dlapy3.f,,, +laqgb,slaqgb.f,dlaqgb.f,claqgb.f,zlaqgb.f, +laqge,slaqge.f,dlaqge.f,claqge.f,zlaqge.f, +laqhb,,,claqhb.f,zlaqhb.f, +laqhe,,,claqhe.f,zlaqhe.f, +laqhp,,,claqhp.f,zlaqhp.f, +laqp2,slaqp2.f,dlaqp2.f,claqp2.f,zlaqp2.f, +laqps,slaqps.f,dlaqps.f,claqps.f,zlaqps.f, +laqr0,slaqr0.f,dlaqr0.f,claqr0.f,zlaqr0.f, +laqr1,slaqr1.f,dlaqr1.f,claqr1.f,zlaqr1.f, +laqr2,slaqr2.f,dlaqr2.f,claqr2.f,zlaqr2.f, +laqr3,slaqr3.f,dlaqr3.f,claqr3.f,zlaqr3.f, +laqr4,slaqr4.f,dlaqr4.f,claqr4.f,zlaqr4.f, +laqr5,slaqr5.f,dlaqr5.f,claqr5.f,zlaqr5.f, +laqsb,slaqsb.f,dlaqsb.f,claqsb.f,zlaqsb.f, +laqsp,slaqsp.f,dlaqsp.f,claqsp.f,zlaqsp.f, +laqsy,slaqsy.f,dlaqsy.f,claqsy.f,zlaqsy.f, +laqtr,slaqtr.f,dlaqtr.f,,, +lar1v,slar1v.f,dlar1v.f,clar1v.f,zlar1v.f, +lar2v,slar2v.f,dlar2v.f,clar2v.f,zlar2v.f, +larcm,,,clarcm.f,zlarcm.f, +larf,slarf.f,dlarf.f,clarf.f,zlarf.f, +larfb,slarfb.f,dlarfb.f,clarfb.f,zlarfb.f, +larfg,slarfg.f,dlarfg.f,clarfg.f,zlarfg.f, +larfgp,slarfgp.f,dlarfgp.f,clarfgp.f,zlarfgp.f, +larft,slarft.f,dlarft.f,clarft.f,zlarft.f, +larfx,slarfx.f,dlarfx.f,clarfx.f,zlarfx.f, +largv,slargv.f,dlargv.f,clargv.f,zlargv.f, +larnv,slarnv.f,dlarnv.f,clarnv.f,zlarnv.f, +larra,slarra.f,dlarra.f,,, +larrb,slarrb.f,dlarrb.f,,, +larrc,slarrc.f,dlarrc.f,,, +larrd,slarrd.f,dlarrd.f,,, +larre,slarre.f,dlarre.f,,, +larrf,slarrf.f,dlarrf.f,,, +larrj,slarrj.f,dlarrj.f,,, +larrk,slarrk.f,dlarrk.f,,, +larrr,slarrr.f,dlarrr.f,,, +larrv,slarrv.f,dlarrv.f,clarrv.f,zlarrv.f, +lartg,slartg.f,dlartg.f,clartg.f,zlartg.f, +lartgp,slartgp.f,dlartgp.f,,, +lartgs,slartgs.f,dlartgs.f,,, +lartv,slartv.f,dlartv.f,clartv.f,zlartv.f, +laruv,slaruv.f,dlaruv.f,,, +larz,slarz.f,dlarz.f,clarz.f,zlarz.f, +larzb,slarzb.f,dlarzb.f,clarzb.f,zlarzb.f, +larzt,slarzt.f,dlarzt.f,clarzt.f,zlarzt.f, +las2,slas2.f,dlas2.f,,, +lascl,slascl.f,dlascl.f,clascl.f,zlascl.f, +lasd0,slasd0.f,dlasd0.f,,, +lasd1,slasd1.f,dlasd1.f,,, +lasd2,slasd2.f,dlasd2.f,,, +lasd3,slasd3.f,dlasd3.f,,, +lasd4,slasd4.f,dlasd4.f,,, +lasd5,slasd5.f,dlasd5.f,,, +lasd6,slasd6.f,dlasd6.f,,, +lasd7,slasd7.f,dlasd7.f,,, +lasd8,slasd8.f,dlasd8.f,,, +lasda,slasda.f,dlasda.f,,, +lasdq,slasdq.f,dlasdq.f,,, +lasdt,slasdt.f,,,, +lasdt,,dlasdt.f,,, +laset,slaset.f,dlaset.f,claset.f,zlaset.f, +lasq1,slasq1.f,dlasq1.f,,, +lasq2,slasq2.f,dlasq2.f,,, +lasq4,slasq4.f,dlasq4.f,,, +lasq5,slasq5.f,dlasq5.f,,, +lasq6,slasq6.f,dlasq6.f,,, +lasr,slasr.f,dlasr.f,clasr.f,zlasr.f, +lasrt,slasrt.f,dlasrt.f,,, +lassq,slassq.f,dlassq.f,classq.f,zlassq.f, +lasv2,slasv2.f,dlasv2.f,,, +laswp,slaswp.f,dlaswp.f,claswp.f,zlaswp.f, +lasy2,slasy2.f,dlasy2.f,,, +lasyf,slasyf.f,dlasyf.f,clasyf.f,zlasyf.f, +lat2c,,,,zlat2c.f, +lat2s,,dlat2s.f,,, +latbs,slatbs.f,dlatbs.f,clatbs.f,zlatbs.f, +latdf,slatdf.f,dlatdf.f,clatdf.f,zlatdf.f, +latps,slatps.f,dlatps.f,clatps.f,zlatps.f, +latrd,slatrd.f,dlatrd.f,clatrd.f,zlatrd.f, +latrs,slatrs.f,dlatrs.f,clatrs.f,zlatrs.f, +latrz,slatrz.f,dlatrz.f,clatrz.f,zlatrz.f, +lauu2,slauu2.f,dlauu2.f,clauu2.f,zlauu2.f, +lauum,slauum.f,dlauum.f,clauum.f,zlauum.f, +opgtr,sopgtr.f,dopgtr.f,,, +opmtr,sopmtr.f,dopmtr.f,,, +orbdb,sorbdb.f,dorbdb.f,,, +orcsd,sorcsd.f,dorcsd.f,,, +org2l,sorg2l.f,dorg2l.f,,, +org2r,sorg2r.f,dorg2r.f,,, +orgbr,sorgbr.f,dorgbr.f,,, +orghr,sorghr.f,dorghr.f,,, +orgl2,sorgl2.f,dorgl2.f,,, +orglq,sorglq.f,dorglq.f,,, +orgql,sorgql.f,dorgql.f,,, +orgqr,sorgqr.f,dorgqr.f,,, +orgr2,sorgr2.f,dorgr2.f,,, +orgrq,sorgrq.f,dorgrq.f,,, +orgtr,sorgtr.f,dorgtr.f,,, +orm2l,sorm2l.f,dorm2l.f,,, +orm2r,sorm2r.f,dorm2r.f,,, +ormbr,sormbr.f,dormbr.f,,, +ormhr,sormhr.f,dormhr.f,,, +orml2,sorml2.f,dorml2.f,,, +ormlq,sormlq.f,dormlq.f,,, +ormql,sormql.f,dormql.f,,, +ormqr,sormqr.f,dormqr.f,,, +ormr2,sormr2.f,dormr2.f,,, +ormr3,sormr3.f,dormr3.f,,, +ormrq,sormrq.f,dormrq.f,,, +ormrz,sormrz.f,dormrz.f,,, +ormtr,sormtr.f,dormtr.f,,, +pbcon,spbcon.f,dpbcon.f,cpbcon.f,zpbcon.f, +pbequ,spbequ.f,dpbequ.f,cpbequ.f,zpbequ.f, +pbrfs,spbrfs.f,dpbrfs.f,cpbrfs.f,zpbrfs.f, +pbstf,spbstf.f,dpbstf.f,cpbstf.f,zpbstf.f, +pbsv,spbsv.f,dpbsv.f,cpbsv.f,zpbsv.f, +pbsvx,spbsvx.f,dpbsvx.f,cpbsvx.f,zpbsvx.f, +pbtf2,spbtf2.f,dpbtf2.f,cpbtf2.f,zpbtf2.f, +pbtrf,spbtrf.f,dpbtrf.f,cpbtrf.f,zpbtrf.f, +pbtrs,spbtrs.f,dpbtrs.f,cpbtrs.f,zpbtrs.f, +pftrf,spftrf.f,dpftrf.f,cpftrf.f,zpftrf.f, +pftri,spftri.f,dpftri.f,cpftri.f,zpftri.f, +pftrs,spftrs.f,dpftrs.f,cpftrs.f,zpftrs.f, +pocon,spocon.f,dpocon.f,cpocon.f,zpocon.f, +poequ,spoequ.f,dpoequ.f,cpoequ.f,zpoequ.f, +poequb,spoequb.f,dpoequb.f,cpoequb.f,zpoequb.f, +porfs,sporfs.f,dporfs.f,cporfs.f,zporfs.f, +posv,sposv.f,dposv.f,cposv.f,zposv.f, +posvx,sposvx.f,dposvx.f,cposvx.f,zposvx.f, +potf2,spotf2.f,dpotf2.f,cpotf2.f,zpotf2.f, +potrf,spotrf.f,dpotrf.f,cpotrf.f,zpotrf.f, +potri,spotri.f,dpotri.f,cpotri.f,zpotri.f, +potrs,spotrs.f,dpotrs.f,cpotrs.f,zpotrs.f, +ppcon,sppcon.f,dppcon.f,cppcon.f,zppcon.f, +ppequ,sppequ.f,dppequ.f,cppequ.f,zppequ.f, +pprfs,spprfs.f,dpprfs.f,cpprfs.f,zpprfs.f, +ppsv,sppsv.f,dppsv.f,cppsv.f,zppsv.f, +ppsvx,sppsvx.f,dppsvx.f,cppsvx.f,zppsvx.f, +pptrf,spptrf.f,dpptrf.f,cpptrf.f,zpptrf.f, +pptri,spptri.f,dpptri.f,cpptri.f,zpptri.f, +pptrs,spptrs.f,dpptrs.f,cpptrs.f,zpptrs.f, +pstf2,spstf2.f,dpstf2.f,cpstf2.f,zpstf2.f, +pstrf,spstrf.f,dpstrf.f,cpstrf.f,zpstrf.f, +ptcon,sptcon.f,dptcon.f,cptcon.f,zptcon.f, +pteqr,spteqr.f,dpteqr.f,cpteqr.f,zpteqr.f, +ptrfs,sptrfs.f,dptrfs.f,cptrfs.f,zptrfs.f, +ptsv,sptsv.f,dptsv.f,cptsv.f,zptsv.f, +ptsvx,sptsvx.f,dptsvx.f,cptsvx.f,zptsvx.f, +pttrf,spttrf.f,dpttrf.f,cpttrf.f,zpttrf.f, +pttrs,spttrs.f,dpttrs.f,cpttrs.f,zpttrs.f, +ptts2,sptts2.f,dptts2.f,cptts2.f,zptts2.f, +rot,,,crot.f,zrot.f, +rscl,srscl.f,drscl.f,csrscl.f,zdrscl.f, +sbev,ssbev.f,dsbev.f,,, +sbevd,ssbevd.f,dsbevd.f,,, +sbevx,ssbevx.f,dsbevx.f,,, +sbgst,ssbgst.f,dsbgst.f,,, +sbgv,ssbgv.f,dsbgv.f,,, +sbgvd,ssbgvd.f,dsbgvd.f,,, +sbgvx,ssbgvx.f,dsbgvx.f,,, +sbtrd,ssbtrd.f,dsbtrd.f,,, +sfrk,ssfrk.f,dsfrk.f,,, +sgesv,,dsgesv.f,,, +spcon,sspcon.f,dspcon.f,cspcon.f,zspcon.f, +spev,sspev.f,dspev.f,,, +spevd,sspevd.f,dspevd.f,,, +spevx,sspevx.f,dspevx.f,,, +spgst,sspgst.f,dspgst.f,,, +spgv,sspgv.f,dspgv.f,,, +spgvd,sspgvd.f,dspgvd.f,,, +spgvx,sspgvx.f,dspgvx.f,,, +spmv,,,cspmv.f,zspmv.f, +sposv,,dsposv.f,,, +spr,,,cspr.f,zspr.f, +sprfs,ssprfs.f,dsprfs.f,csprfs.f,zsprfs.f, +spsv,sspsv.f,dspsv.f,cspsv.f,zspsv.f, +spsvx,sspsvx.f,dspsvx.f,cspsvx.f,zspsvx.f, +sptrd,ssptrd.f,dsptrd.f,,, +sptrf,ssptrf.f,dsptrf.f,csptrf.f,zsptrf.f, +sptri,ssptri.f,dsptri.f,csptri.f,zsptri.f, +sptrs,ssptrs.f,dsptrs.f,csptrs.f,zsptrs.f, +stebz,sstebz.f,dstebz.f,,, +stedc,sstedc.f,dstedc.f,cstedc.f,zstedc.f, +stegr,sstegr.f,dstegr.f,cstegr.f,zstegr.f, +stein,sstein.f,dstein.f,cstein.f,zstein.f, +stemr,sstemr.f,dstemr.f,cstemr.f,zstemr.f, +steqr,ssteqr.f,dsteqr.f,csteqr.f,zsteqr.f, +sterf,ssterf.f,dsterf.f,,, +stev,sstev.f,dstev.f,,, +stevd,sstevd.f,dstevd.f,,, +stevr,sstevr.f,dstevr.f,,, +stevx,sstevx.f,dstevx.f,,, +sum1,,,scsum1.f,dzsum1.f, +sycon,ssycon.f,dsycon.f,csycon.f,zsycon.f, +syconv,ssyconv.f,dsyconv.f,csyconv.f,zsyconv.f, +syequb,ssyequb.f,dsyequb.f,csyequb.f,zsyequb.f, +syev,ssyev.f,dsyev.f,,, +syevd,ssyevd.f,dsyevd.f,,, +syevr,ssyevr.f,dsyevr.f,,, +syevx,ssyevx.f,dsyevx.f,,, +sygs2,ssygs2.f,dsygs2.f,,, +sygst,ssygst.f,dsygst.f,,, +sygv,ssygv.f,dsygv.f,,, +sygvd,ssygvd.f,dsygvd.f,,, +sygvx,ssygvx.f,dsygvx.f,,, +symv,,,csymv.f,zsymv.f, +syr,,,csyr.f,zsyr.f, +syrfs,ssyrfs.f,dsyrfs.f,csyrfs.f,zsyrfs.f, +sysv,ssysv.f,dsysv.f,csysv.f,zsysv.f, +sysvx,ssysvx.f,dsysvx.f,csysvx.f,zsysvx.f, +syswapr,ssyswapr.f,dsyswapr.f,csyswapr.f,zsyswapr.f, +sytd2,ssytd2.f,dsytd2.f,,, +sytf2,ssytf2.f,dsytf2.f,csytf2.f,zsytf2.f, +sytrd,ssytrd.f,dsytrd.f,,, +sytrf,ssytrf.f,dsytrf.f,csytrf.f,zsytrf.f, +sytri,ssytri.f,dsytri.f,csytri.f,zsytri.f, +sytri2,ssytri2.f,dsytri2.f,csytri2.f,zsytri2.f, +sytri2x,ssytri2x.f,dsytri2x.f,csytri2x.f,zsytri2x.f, +sytrs,ssytrs.f,dsytrs.f,csytrs.f,zsytrs.f, +sytrs2,ssytrs2.f,dsytrs2.f,csytrs2.f,zsytrs2.f, +tbcon,stbcon.f,dtbcon.f,ctbcon.f,ztbcon.f, +tbrfs,stbrfs.f,dtbrfs.f,ctbrfs.f,ztbrfs.f, +tbtrs,stbtrs.f,dtbtrs.f,ctbtrs.f,ztbtrs.f, +tfsm,stfsm.f,dtfsm.f,ctfsm.f,ztfsm.f, +tftri,stftri.f,dtftri.f,ctftri.f,ztftri.f, +tfttp,stfttp.f,dtfttp.f,ctfttp.f,ztfttp.f, +tfttr,stfttr.f,dtfttr.f,ctfttr.f,ztfttr.f, +tgevc,stgevc.f,dtgevc.f,ctgevc.f,ztgevc.f, +tgex2,stgex2.f,dtgex2.f,ctgex2.f,ztgex2.f, +tgexc,stgexc.f,dtgexc.f,ctgexc.f,ztgexc.f, +tgsen,stgsen.f,dtgsen.f,ctgsen.f,ztgsen.f, +tgsja,stgsja.f,dtgsja.f,ctgsja.f,ztgsja.f, +tgsna,stgsna.f,dtgsna.f,ctgsna.f,ztgsna.f, +tgsy2,stgsy2.f,dtgsy2.f,ctgsy2.f,ztgsy2.f, +tgsyl,stgsyl.f,dtgsyl.f,ctgsyl.f,ztgsyl.f, +tpcon,stpcon.f,dtpcon.f,ctpcon.f,ztpcon.f, +tprfs,stprfs.f,dtprfs.f,ctprfs.f,ztprfs.f, +tptri,stptri.f,dtptri.f,ctptri.f,ztptri.f, +tptrs,stptrs.f,dtptrs.f,ctptrs.f,ztptrs.f, +tpttf,stpttf.f,dtpttf.f,ctpttf.f,ztpttf.f, +tpttr,stpttr.f,dtpttr.f,ctpttr.f,ztpttr.f, +trcon,strcon.f,dtrcon.f,ctrcon.f,ztrcon.f, +trevc,strevc.f,dtrevc.f,ctrevc.f,ztrevc.f, +trexc,strexc.f,dtrexc.f,ctrexc.f,ztrexc.f, +trrfs,strrfs.f,dtrrfs.f,ctrrfs.f,ztrrfs.f, +trsen,strsen.f,dtrsen.f,ctrsen.f,ztrsen.f, +trsna,strsna.f,dtrsna.f,ctrsna.f,ztrsna.f, +trsyl,strsyl.f,dtrsyl.f,ctrsyl.f,ztrsyl.f, +trti2,strti2.f,dtrti2.f,ctrti2.f,ztrti2.f, +trtri,strtri.f,dtrtri.f,ctrtri.f,ztrtri.f, +trtrs,strtrs.f,dtrtrs.f,ctrtrs.f,ztrtrs.f, +trttf,strttf.f,dtrttf.f,ctrttf.f,ztrttf.f, +trttp,strttp.f,dtrttp.f,ctrttp.f,ztrttp.f, +tzrzf,stzrzf.f,dtzrzf.f,ctzrzf.f,ztzrzf.f, +unbdb,,,cunbdb.f,zunbdb.f, +uncsd,,,cuncsd.f,zuncsd.f, +ung2l,,,cung2l.f,zung2l.f, +ung2r,,,cung2r.f,zung2r.f, +ungbr,,,cungbr.f,zungbr.f, +unghr,,,cunghr.f,zunghr.f, +ungl2,,,cungl2.f,zungl2.f, +unglq,,,cunglq.f,zunglq.f, +ungql,,,cungql.f,zungql.f, +ungqr,,,cungqr.f,zungqr.f, +ungr2,,,cungr2.f,zungr2.f, +ungrq,,,cungrq.f,zungrq.f, +ungtr,,,cungtr.f,zungtr.f, +unm2l,,,cunm2l.f,zunm2l.f, +unm2r,,,cunm2r.f,zunm2r.f, +unmbr,,,cunmbr.f,zunmbr.f, +unmhr,,,cunmhr.f,zunmhr.f, +unml2,,,cunml2.f,zunml2.f, +unmlq,,,cunmlq.f,zunmlq.f, +unmql,,,cunmql.f,zunmql.f, +unmqr,,,cunmqr.f,zunmqr.f, +unmr2,,,cunmr2.f,zunmr2.f, +unmr3,,,cunmr3.f,zunmr3.f, +unmrq,,,cunmrq.f,zunmrq.f, +unmrz,,,cunmrz.f,zunmrz.f, +unmtr,,,cunmtr.f,zunmtr.f, +upgtr,,,cupgtr.f,zupgtr.f, +upmtr,,,cupmtr.f,zupmtr.f, +chla_transtype,,,,,chla_transtype.f +ieeeck,,,,,ieeeck.f +ladiag,,,,,iladiag.f +laprec,,,,,ilaprec.f +latrans,,,,,ilatrans.f +lauplo,,,,,ilauplo.f diff --git a/lapack-ffi-tools.cabal b/lapack-ffi-tools.cabal new file mode 100644 --- /dev/null +++ b/lapack-ffi-tools.cabal @@ -0,0 +1,87 @@ +Name: lapack-ffi-tools +Version: 0.0 +License: BSD3 +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://hub.darcs.net/thielema/lapack-ffi-tools/ +Category: Math +Synopsis: Generator for Haskell interface to Fortran LAPACK +Description: + LAPACK is a package for efficient numerically robust linear algebra. + The original implementation is written in FORTRAN. + . + The program in this package generates the modules + for the packages @blas-ffi@, @blas-carray@, @lapack-ffi@, @lapack-carray@ + from the FORTRAN source files. +Tested-With: GHC==7.4.2, GHC==7.8.4 +Cabal-Version: >=1.14 +Build-Type: Simple +Data-Files: + data/blas.csv + data/lapack.csv + +Source-Repository this + Tag: 0.0 + Type: darcs + Location: http://hub.darcs.net/thielema/lapack-ffi-tools/ + +Source-Repository head + Type: darcs + Location: http://hub.darcs.net/thielema/lapack-ffi-tools/ + +Executable create-lapack-ffi-single + Build-Depends: + parsec >=3.1 && <3.2, + explicit-exception >=0.1.7.3 && <0.2, + transformers >=0.3 && <0.6, + containers >=0.4 && <0.6, + utility-ht >=0.0.12 && <0.1, + base >=4.5 && <4.11 + Main-Is: MainSingle.hs + Other-Modules: + CreateBinding + Parser.Signature + Parser.Combinator + Hs-Source-Dirs: src + Default-Language: Haskell98 + + GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-unused-do-bind + +Executable create-lapack-ffi + Build-Depends: + cassava >=0.4.5.1 && <0.5, + optparse-applicative >=0.11 && <0.15, + parsec >=3.1 && <3.2, + explicit-exception >=0.1.7.3 && <0.2, + transformers >=0.3 && <0.6, + pathtype >=0.8 && <0.9, + unordered-containers >=0.2.8 && <0.3, + containers >=0.4 && <0.6, + vector >=0.10 && <0.13, + bytestring >=0.9.2.1 && <0.11, + non-empty >=0.2 && <0.4, + utility-ht >=0.0.14 && <0.1, + base >=4.5 && <4.11 + Main-Is: MainAll.hs + Other-Modules: + CreateBinding + Parser.Signature + Parser.Combinator + Type + Hs-Source-Dirs: src + Default-Language: Haskell98 + + GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-unused-do-bind + +Executable create-lapack-csv + Build-Depends: + filepath >=1.3 && <1.5, + containers >=0.4 && <0.6, + utility-ht >=0.0.12 && <0.1, + base >=4.5 && <4.11 + Main-Is: CreateCSV.hs + Hs-Source-Dirs: src + Default-Language: Haskell98 + + GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-unused-do-bind diff --git a/src/CreateBinding.hs b/src/CreateBinding.hs new file mode 100644 --- /dev/null +++ b/src/CreateBinding.hs @@ -0,0 +1,424 @@ +module CreateBinding where + +import qualified Parser.Signature as Parser +import qualified Type +import Parser.Signature (Identifier) + +import qualified Text.ParserCombinators.Parsec as Parsec + +import qualified Control.Monad.Exception.Synchronous as ME +import qualified Control.Monad.Trans.Writer as MW +import qualified Control.Functor.HT as Func +import Control.Monad (when) + +import qualified Data.Foldable as Fold +import qualified Data.List.Match as Match +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Traversable (forM) +import Data.Tuple.HT (mapPair, mapFst, mapSnd, mapSnd3, fst3, snd3, thd3) +import Data.Map (Map) +import Data.Set (Set) +import Data.Char (toLower, isSpace, isAlpha, isAlphaNum) +import Data.Maybe (fromMaybe, mapMaybe) + +import Text.Printf (printf) + + +type MonoMapping = Type.Mapping String Type.Mono +data Mapping = Mapping (Maybe [String]) Bool +type RawParameter = + (String, (Type.Mono, Mapping), + Maybe (Parser.Direction, Type.Mono, Maybe MonoMapping)) +type Parameter = (String, (Type.Mono, MonoMapping, Parser.Direction)) + +examineParamInfo :: + ((Identifier, [String], Maybe Type.Mono), [Parser.ParamDecl], + Map String (Parser.Direction, Type.Mono, Maybe MonoMapping)) -> + ME.Exceptional String (Identifier, [RawParameter], Maybe Type.Mono) +examineParamInfo ((name, paramNames, returnType), paramDecls, paramDirs) = + let (paramTypes,externals) = + ListHT.unzipEithers $ + map + (\decl -> + case decl of + Parser.Type typ ps -> Left (typ,ps) + Parser.External ps -> Right ps) + paramDecls + externalSet :: Set String + externalSet = Fold.foldMap Set.fromList externals + typeMap = + Map.fromList $ + concatMap + (\(typ,params) -> map (\(param,dims) -> (param,(typ,dims))) params) + paramTypes + mapp pm param = Mapping pm $ Set.member param externalSet + in fmap (\params -> (name, params, returnType)) $ + forM paramNames $ \param -> + ME.fromMaybe ("no type declaration found for " ++ param) $ + fmap + (\(typ,pm) -> + (param, (typ, mapp pm param), Map.lookup param paramDirs)) $ + Map.lookup param typeMap + +fallbackMapping :: Mapping -> MonoMapping +fallbackMapping pm = + case pm of + Mapping Nothing False -> Type.Scalar + Mapping (Just dims) False -> Type.Array dims + Mapping _ True -> Type.Function 0 Type.Integer + +parameterFromRaw :: RawParameter -> Parameter +parameterFromRaw (name, (typ,dims), mdir) = + (name, + case mdir of + Nothing -> (typ, fallbackMapping dims, Parser.Input) + Just (dir, _typ, cmtDims) -> + (typ, fromMaybe (fallbackMapping dims) cmtDims, dir)) + +compatibleDimension :: String -> String -> Bool +compatibleDimension x y = x == ("0:"++y++"-1") || x==y + +compatibleDimensions :: [String] -> [String] -> Bool +compatibleDimensions = + let go [] [] = True + go ["*"] [_] = True + go ["0:*"] [_] = True + go (x:xs) (y:ys) = compatibleDimension x y && go xs ys + go [] _ = False + go _ [] = False + trim = filter (not . isSpace) + in \xs ys -> go (map trim xs) (map trim ys) + +compatibleMapping :: Mapping -> MonoMapping -> Bool +compatibleMapping (Mapping Nothing False) Type.Scalar = True +compatibleMapping (Mapping (Just dims0) False) (Type.Array dims1) = + compatibleDimensions dims0 dims1 +compatibleMapping (Mapping Nothing True) (Type.Function _ _) = True +compatibleMapping _ _ = False + +combineParamInfo :: [RawParameter] -> MW.Writer [String] [Parameter] +combineParamInfo params = do + let (completeParams, incompleteParams) = + ListHT.partitionMaybe (Func.mapThd3 id) params + when (not $ null incompleteParams) $ MW.tell $ (:[]) $ + "parameters without or with ill-formatted details: " ++ + List.intercalate ", " (map fst3 incompleteParams) + let inconsistentTypes = + filter (\(_name, typ, cmt) -> fst typ /= snd3 cmt) completeParams + when (not $ null inconsistentTypes) $ MW.tell $ (:[]) $ + "parameters with inconsistent type definitions: " ++ + List.intercalate ", " (map fst3 inconsistentTypes) + let inconsistentDims = + filter + (\(_name, typ, cmt) -> + Fold.any + (\cmtDims -> not $ compatibleMapping (snd typ) cmtDims) + (thd3 cmt)) + completeParams + when (not $ null inconsistentDims) $ MW.tell $ (:[]) $ + "parameters with inconsistent dimension lists: " ++ + List.intercalate ", " (map fst3 inconsistentDims) + return $ map parameterFromRaw params + +parseHeader :: + Parsec.Parser (MW.Writer [String] (Identifier, [Parameter], Maybe Type.Mono)) +parseHeader = + fmap (Func.mapSnd3 combineParamInfo) $ + ME.switch fail return . examineParamInfo =<< Parser.header3_4 + + +foreignFromParameters :: + [(name, (Type.Mono, Type.Mapping dims Type.Mono, dir))] -> + Maybe Type.Mono -> Type.Foreign Type.Mono +foreignFromParameters params returnType = + Type.Foreign + (map + (\(_name, (typ, mapping, _dir)) -> + case mapping of + Type.Scalar -> Type.Ptr typ + Type.Array _ -> Type.Ptr typ + Type.Function n param -> Type.FunPtr n param typ) + params) + returnType + +formatForeignCall :: ((String, String), Type.Foreign Type.Mono) -> String +formatForeignCall ((haskellName, fortranName), foreignSig) = + printf "foreign import ccall \"%s_\"\n" (map toLower fortranName) ++ + printf " %s :: %s\n" haskellName (Type.formatForeign foreignSig) + + +contFromType :: Type.Mono -> String +contFromType typ = + case typ of + Type.Logical -> "Call.bool" + Type.Character -> "Call.char" + Type.Integer -> "Call.cint" + Type.RealSingle -> "Call.float" + Type.RealDouble -> "Call.double" + Type.ComplexSingle -> "Call.complexFloat" + Type.ComplexDouble -> "Call.complexDouble" + +isIOArray :: Parser.Direction -> Bool +isIOArray dir = + case dir of + Parser.InputOutput -> True + Parser.InputWorkspace -> True + _ -> False + +contFromArrayType :: Parameter -> String +contFromArrayType (name, (typ, dims, dir)) = + case dims of + Type.Scalar -> + if isInputDir dir + then contFromType typ ++ " " ++ name + else "Call.alloca" + Type.Array _ -> + (if isIOArray dir then "Call.ioarray " else "Call.array ") ++ name + Type.Function _ _ -> "pure " ++ name + +parens :: String -> String +parens expr = "("++expr++")" + +parensIfNeeded :: String -> String +parensIfNeeded expr = if all isAlphaNum expr then expr else parens expr + +arrayTypeFromBool :: Bool -> String +arrayTypeFromBool mutable = if mutable then "IOCArray" else "CArray" + +arrayTypeFromDir :: Parser.Direction -> String +arrayTypeFromDir = arrayTypeFromBool . isIOArray + +isInputDir :: Parser.Direction -> Bool +isInputDir dir = + case dir of + Parser.Input -> True + Parser.InputOutput -> True + Parser.InputWorkspace -> True + Parser.Output -> False + Parser.Workspace -> False + +isOutput :: (Type.Mono, Type.Mapping dim Type.Mono, Parser.Direction) -> Bool +isOutput (_, dims, dir) = + case dir of + Parser.Input -> False + Parser.InputOutput -> Type.isScalar dims + Parser.InputWorkspace -> False + Parser.Output -> True + Parser.Workspace -> False + + +parameterName :: String -> String +parameterName fortranName = + case map toLower fortranName of + "id" -> "id_" + "in" -> "in_" + "sin" -> "sin_" + "type" -> "type_" + haskellName -> haskellName + +spanIdentifier :: String -> (String, String) +spanIdentifier str = + case str of + [] -> ([], str) + c:cs -> + if isAlpha c + then mapFst (c:) $ span isAlphaNum cs + else ([], str) + +isIdentifier :: String -> Bool +isIdentifier str = + case str of + [] -> False + c:cs -> isAlpha c && all isAlphaNum cs + +sizeExpression :: String -> String -> (String, [String]) +sizeExpression name = + let c <: ~(strRem,vars) = (c:strRem, vars) + str <++ ~(strRem,vars) = (str++strRem, vars) + addVar var str = mapSnd (var:) $ var <++ str + go paren str = + case spanIdentifier str of + ("", cs) -> + case cs of + "" -> + (if null paren then "" else "{- too many closing parens -}", + []) + ' ':cs1 -> go paren cs1 + '/':cs1 -> "`div`" <++ go paren cs1 + '*':'*':cs1 -> "^!" <++ go paren cs1 + '(':cs1 -> '(' <: go (')':paren) cs1 + ')':cs1 -> + case paren of + p:ps -> p <: go ps cs1 + [] -> " {- missing closing -} )" <++ go paren cs1 + c:cs1 -> c <: go paren cs1 + ("MAX", '(':cs) -> "maximum[" <++ go (']':paren) cs + ("max", '(':cs) -> "maximum[" <++ go (']':paren) cs + ("MIN", '(':cs) -> "minimum[" <++ go (']':paren) cs + ("min", '(':cs) -> "minimum[" <++ go (']':paren) cs + ("ABS", '(':cs) -> "abs(" <++ go (')':paren) cs + ("abs", '(':cs) -> "abs(" <++ go (')':paren) cs + ("N", ' ':'l':'g':' ':'N':cs) -> addVar "nlgn" (go paren cs) + (ident, cs) -> addVar (parameterName ident) (go paren cs) + sizeName = name ++ "Size" + in \str -> if str=="*" then (sizeName, [sizeName]) else go [] str + +-- like nubBy but needs (n * log n) operations instead of (n^2) +ordnub :: (Ord a) => Set a -> [(a,b)] -> [(a,b)] +ordnub initSet xs = + map fst $ filter snd $ zip xs $ zipWith (Set.notMember . fst) xs $ + scanl (flip Set.insert) initSet $ map fst xs + + +peekOut :: Parameter -> String +peekOut (name, (typ, dims, _dir)) = + case dims of + Type.Scalar -> + case typ of + Type.Character -> printf "fmap castCCharToChar (peek %sPtr)" name + Type.Integer -> printf "fmap fromIntegral (peek %sPtr)" name + _ -> printf "peek %sPtr" name + Type.Array _ -> "pure " ++ name + Type.Function _ _ -> + printf "error \"function %s cannot be an output\"" name + +formatOutputTuple :: Type.Format typ => Type.Wrapper typ -> String +formatOutputTuple (Type.Wrapper _inputs returnType outputs) = + let outputTuple = + CreateBinding.parens $ List.intercalate ", " $ + map (uncurry $ Type.formatArray "CArray") outputs + in case (returnType, outputs) of + (Nothing, _) -> outputTuple + (Just t, []) -> Type.format t + -- I have not encountered this case so far + (Just t, _) -> printf "(%s, %s)" (Type.format t) outputTuple + + +formatCArrayWrapper :: + (String, [Parameter], Maybe Type.Mono) -> (String, Type.Wrapper Type.Mono) +formatCArrayWrapper (name, params0, returnType) = + let prepare (param,info) = + (param, + mapSnd3 + (Type.mapMappings (map (sizeExpression param) . reverse)) info) + pparams = map (prepare . mapFst parameterName) params0 + params = map (mapSnd (mapSnd3 (Type.mapMapping fst))) pparams + (inputArrays,allocArrays) = + ListHT.partition (isInputDir . snd . snd) $ + mapMaybe + (\(param,(_typ,mapping,dir)) -> do + dimVars <- Type.maybeArray mapping + return (param,(dimVars,dir))) + pparams + dimNames param = map (printf "%sDim%d" param) [(0::Int)..] + allDimVars = + concatMap + (\(param,(dimVars,_dir)) -> zip dimVars $ dimNames param) + inputArrays + inputsDup = + concatMap + (\(param, (typ,mapping,dir)) -> + let (dims,vars) = + case mapping of + Type.Scalar -> (Type.Scalar, []) + Type.Function n paramType -> + (Type.Function n paramType, []) + Type.Array dimVars -> + mapPair (Type.Array, concat) $ Func.unzip dimVars + in if isInputDir dir + then [(param, (typ,dims,dir))] + else map (flip (,) (Type.Integer,Type.Scalar,Parser.Input)) vars) + pparams + inputVars = + Set.fromList $ + map fst inputsDup ++ + filter isIdentifier (map (fst . fst) allDimVars) + (varSet, (assigns,checks)) = + mapSnd (mapPair (map snd, map snd) . ListHT.partition fst) $ + List.mapAccumL + (\set rel@((dim,_vars),_dimId) -> + let isIdent = isIdentifier dim + in (if isIdent then Set.insert dim set else set, + (isIdent && Set.notMember dim set, rel))) + Set.empty + allDimVars + inputs = ordnub varSet inputsDup + usedVars = + Set.fromList $ + concatMap + (\((dim,vars),_dimId) -> + if isIdentifier dim then dim:vars else vars) + checks + ++ + map fst params + ++ + concatMap + (\(_param,(dimVars,_dir)) -> concatMap snd dimVars) + allocArrays + outputs = filter (isOutput . snd) params + wrapper = + Type.Wrapper + (map + (\(_param,(typ,dims,dir)) -> (typ, dims, isIOArray dir)) + inputs) + returnType + (map (\(_param,(typ,dims,_dir)) -> (typ,dims)) outputs) + in flip (,) wrapper $ + unlines $ + printf "%s ::" name : + map + (\(param,(typ,dims,dir)) -> + printf " %s {- ^ %s -} ->" + (Type.formatArray (arrayTypeFromDir dir) typ dims) param) + inputs ++ + (" IO " ++ formatOutputTuple wrapper) : + (name ++ concatMap ((' ':) . fst) inputs ++ " = do") : + map + (\(param,(dimVars,dir)) -> + let format = + if isIOArray dir + then " %s <- Call.sizes%d <$> getBounds %s" + else " let %s = Call.sizes%d $ bounds %s" + dimIdents = Match.take dimVars $ dimNames param + in printf format + (Type.formatTuple dimIdents) (length dimIdents) param) + inputArrays ++ + map + (\((dim,_),dimId) -> + let underscore = if Set.member dim usedVars then "" else "_" + in printf " let %s%s = %s" underscore dim dimId) + assigns ++ + map + (\((dim,vars),dimId) -> + if Set.isSubsetOf (Set.fromList vars) inputVars + then + printf " Call.assert \"%s: %s == %s\" (%s == %s)" + name dim dimId dim dimId + else + printf " Call.ignore \"%s: %s == %s\" %s" + name dim dimId (dimId::String)) + checks ++ + map + (\(param,(dims,_dir)) -> + printf " %s <- Call.newArray%d%s" + param (length dims) + (concatMap ((' ':) . parensIfNeeded . fst) dims)) + allocArrays ++ + " evalContT $ do" : + map + (\param -> + printf " %sPtr <- %s" (fst param) (contFromArrayType param)) + params ++ + (" liftIO $ FFI." ++ name ++ + concatMap (printf " %sPtr" . fst) params) : + (case outputs of + [] -> [] + [param] -> [" liftIO $ " ++ peekOut param] + _:os -> + printf " liftIO $ pure (%s)" (Match.replicate os ',') + : + map ((" <*> " ++) . peekOut) outputs) ++ + [] diff --git a/src/CreateCSV.hs b/src/CreateCSV.hs new file mode 100644 --- /dev/null +++ b/src/CreateCSV.hs @@ -0,0 +1,32 @@ +module Main where + +import System.FilePath (takeBaseName) + +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Map (Map) +import Data.Maybe (mapMaybe) +import Data.Foldable (foldMap) + + +singleton :: FilePath -> Maybe (Map String (Map Char FilePath)) +singleton "" = Nothing +singleton str@(c:cs) = + Just $ Map.singleton (takeBaseName cs) $ Map.singleton c str + +group :: [String] -> ([Char], [(String, [FilePath])]) +group xs = + let ys = Map.unionsWith Map.union $ mapMaybe singleton xs + columns = Set.toList $ foldMap Map.keysSet ys + emptyColumns = Map.fromList $ map (flip (,) "") columns + in (columns, + Map.toAscList $ fmap (Map.elems . flip Map.union emptyColumns) ys) + +formatCSV :: ([Char], [(String, [FilePath])]) -> [String] +formatCSV (header, rows) = + ("Name," ++ List.intersperse ',' header) : + map (\(name,cells) -> List.intercalate "," $ name:cells) rows + +main :: IO () +main = interact $ unlines . formatCSV . group . lines diff --git a/src/MainAll.hs b/src/MainAll.hs new file mode 100644 --- /dev/null +++ b/src/MainAll.hs @@ -0,0 +1,365 @@ +module Main where + +import qualified CreateBinding +import qualified Type +import Parser.Signature (Identifier(Identifier)) +import CreateBinding + (formatForeignCall, formatCArrayWrapper, parseHeader, + foreignFromParameters, arrayTypeFromBool) + +import qualified Text.ParserCombinators.Parsec as Parsec +import qualified Text.ParserCombinators.Parsec.Error as ParsecError + +import qualified Options.Applicative as OP + +import qualified System.IO as IO +import qualified System.Path.PartClass as PathClass +import qualified System.Path.IO as PathIO +import qualified System.Path as Path +import System.Path.Directory (createDirectoryIfMissing) +import System.Path (takeFileName, ()) + +import Text.Printf (printf) + +import qualified Data.Csv as Csv +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString.Char8 as B +import qualified Data.Vector as Vector +import qualified Data.Foldable as Fold +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Traversable (for, sequenceA, traverse) +import Data.Foldable (forM_) +import Data.Vector (Vector) +import Data.ByteString (ByteString) +import Data.Map (Map) +import Data.Csv ((.:)) +import Data.Tuple.HT (mapSnd, fst3, snd3, thd3) +import Data.Maybe (isNothing) +import Data.Char (toUpper) +import Data.Monoid ((<>)) + +import qualified Control.Monad.Exception.Synchronous as ME +import qualified Control.Monad.Trans.Writer as MW +import qualified Control.Applicative.HT as App +import qualified Control.Functor.HT as Func +import Control.Monad (when, join) +import Control.Applicative (liftA2, (<$>), (<*>)) + + + +class Type.Unification f => Generalize f where + formatGenericSig :: f Type.Poly -> String + +instance Generalize Type.Foreign where + formatGenericSig = Type.formatForeign + +instance Generalize Type.Wrapper where + formatGenericSig wrapper@(Type.Wrapper inputs _returnType _outputs) = + concatMap + (\(typ,dims,dir) -> + printf "%s -> " (Type.formatArray (arrayTypeFromBool dir) typ dims)) + inputs ++ + "IO " ++ CreateBinding.formatOutputTuple wrapper + +prepareClassCall :: + (Generalize f) => + (String, f Type.Poly) -> (String, String, String, Char -> String) +prepareClassCall (name, func) = + let typeName = map toUpper name + sig = formatGenericSig func + newtypeDef = + printf "newtype %s a = %s {get%s :: %s}" typeName typeName typeName sig + in (typeName, sig, newtypeDef, + \abbr -> printf "(%s %c.%s)" typeName abbr name) + +formatClassCall :: + (Generalize f) => Char -> Char -> (String, f Type.Poly) -> String +formatClassCall singleAbbr doubleAbbr func@(name, _) = + let (typeName, sig, newtypeDef, typeBranch) = prepareClassCall func + in unlines $ + "" : + "" : + newtypeDef : + "" : + printf "%s :: Class.Real a => %s" name sig : + printf "%s = get%s $ Class.switchReal %s %s" + name typeName (typeBranch singleAbbr) (typeBranch doubleAbbr) : + [] + +formatClassCallRC :: (Generalize f) => (String, f Type.Poly) -> String +formatClassCallRC func@(name, _) = + let (typeName, sig, newtypeDef, typeBranch) = prepareClassCall func + in unlines $ + "" : + "" : + newtypeDef : + "" : + printf "%s :: Class.Floating a => %s" name sig : + printf "%s = get%s $ Class.switchFloating %s %s %s %s" name typeName + (typeBranch 'S') (typeBranch 'D') (typeBranch 'C') (typeBranch 'Z') : + [] + + +insertExportList :: [String] -> String -> String +insertExportList exports modul = + (\(prefix,suffixes) -> + map fst prefix ++ + case suffixes of + [] -> [] + (_,suffix):_ -> + "(\n" ++ unlines (map (printf " %s,") exports) ++ + " ) " ++ suffix) $ + break (List.isPrefixOf "where" . snd) $ + zip modul (ListHT.tails modul) + +writeHeader :: + (PathClass.AbsRel ar) => + Path.Dir ar -> B.ByteString -> Maybe [String] -> IO (Path.File ar) +writeHeader dstDir modul mexports = do + let makePath = + either (ioError . userError) (return . (dstDir )) . Path.parse + tmplFile <- makePath $ B.unpack modul ++ "_tmpl.hs" + dstFile <- makePath $ B.unpack modul ++ ".hs" + tmpl <- PathIO.readFile tmplFile + PathIO.writeFile dstFile $ + "-- Do not edit! Automatically generated by create-lapack-ffi.\n" ++ + maybe tmpl (flip insertExportList tmpl) mexports + return dstFile + +indent :: String -> String +indent = unlines . map (" " ++) . lines + +formatFileError :: (PathClass.AbsRel ar) => Path.File ar -> String -> String +formatFileError path msg = + printf "\n%s:1:1:\n%s" (Path.toString path) (indent msg) + +formatParseError :: Parsec.ParseError -> String +formatParseError err = + let source = Parsec.errorPos err + in printf "\n%s:%d:%d:\n%s" + (Parsec.sourceName source) + (Parsec.sourceLine source) + (Parsec.sourceColumn source) + (indent $ dropWhile ('\n'==) $ + ParsecError.showErrorMessages + "or" "unknown parse error" "expecting" "unexpected" "end of input" + (ParsecError.errorMessages err)) + +printError :: String -> IO () +printError = IO.hPutStr IO.stderr + +printFileError :: (PathClass.AbsRel ar) => Path.File ar -> String -> IO () +printFileError path msg = printError $ formatFileError path msg + + +nameColumn, miscColumn, floatColumn, doubleColumn, + complexFloatColumn, complexDoubleColumn, + realColumn, complexColumn, genericColumn :: ByteString +nameColumn = B.pack "Name" +miscColumn = B.pack "Misc" +floatColumn = B.pack "Float" +doubleColumn = B.pack "Double" +complexFloatColumn = B.pack "ComplexFloat" +complexDoubleColumn = B.pack "ComplexDouble" + +realColumn = B.pack "Real" +complexColumn = B.pack "Complex" +genericColumn = B.pack "Generic" + + +data FunctionSet = FunctionSet String (Map ByteString Path.RelFile) + +newtype RelFile = RelFile {getRelFile :: Maybe Path.RelFile} + +instance Csv.FromField RelFile where + parseField str = + fmap RelFile $ + if B.null str + then return Nothing + else either fail (return . Just) . Path.parse . B.unpack $ str + +instance Csv.FromNamedRecord FunctionSet where + parseNamedRecord m = do + name <- m .: nameColumn + when (null name) $ fail "empty name" + set <- Csv.parseNamedRecord $ HashMap.delete nameColumn m + return $ FunctionSet name $ Map.mapMaybe getRelFile set + + +type URL = String + +processFunction :: + (PathClass.AbsRel ar) => + (Path.File ar, Path.File ar) -> + URL -> String -> Path.File ar -> + IO (Maybe (Type.Foreign Type.Mono, Type.Wrapper Type.Mono)) +processFunction (ffiFile, carrayFile) url haskellName srcPath = do + content <- PathIO.readFile srcPath + let msignature = do + sig <- + fmap MW.runWriter $ + ME.mapException formatParseError $ ME.fromEither $ + Parsec.parse parseHeader (Path.toString srcPath) content + when + (elem (thd3 $ fst sig) + [Just Type.ComplexSingle, Just Type.ComplexDouble]) $ + ME.throw $ + formatFileError srcPath "complex function result not supported" + return sig + case msignature of + ME.Exception msg -> printError msg >> return Nothing + ME.Success ((Identifier name, params, returnType), msgs) -> do + mapM_ (printFileError srcPath) msgs + let haddock = + if null url + then "\n" + else + printf "\n-- | <%s>\n" + (printf url (Path.toString $ takeFileName srcPath) + :: String) + let foreignSig = foreignFromParameters params returnType + carrayWrapper <- do + let (mono,poly) = + formatCArrayWrapper (haskellName, params, returnType) + PathIO.appendFile carrayFile $ haddock ++ mono + return poly + PathIO.appendFile ffiFile $ + haddock ++ formatForeignCall ((haskellName, name), foreignSig) + return $ Just (foreignSig, carrayWrapper) + +unifyFunctions :: + (Type.Unification f, PathClass.AbsRel ar) => + String -> + Map ByteString (Path.File ar, f Type.Mono) -> + IO (Maybe (f Type.Poly), Maybe (f Type.Poly), Maybe (f Type.Poly)) +unifyFunctions msg monoSigs = do + let unify uni (xPath,xSig) (yPath,ySig) = do + let m = Type.unifySignature uni xSig ySig + when (isNothing m) $ do + printFileError xPath "" + printFileError yPath msg + return m + real <- + fmap join $ sequenceA $ + liftA2 + (unify Type.unifyPrecision) + (Map.lookup floatColumn monoSigs) + (Map.lookup doubleColumn monoSigs) + complex <- + fmap join $ sequenceA $ + liftA2 + (unify Type.unifyPrecision) + (Map.lookup complexFloatColumn monoSigs) + (Map.lookup complexDoubleColumn monoSigs) + let generic = + join $ liftA2 (Type.unifySignature Type.unifyRealComplex) real complex + return (real, complex, generic) + + +writePolymorphic :: + (PathClass.AbsRel ar) => + Path.Dir ar -> + ByteString -> + Vector (String, sig) -> + ((String, sig) -> String) -> + IO () +writePolymorphic dir name polySigs format = do + file <- writeHeader dir name (Just $ Fold.toList $ fmap fst polySigs) + forM_ (Fold.toList polySigs) $ PathIO.appendFile file . format + +writeUnified :: + (PathClass.AbsRel ar, Generalize f) => + Path.Dir ar -> + Vector + (String, + (Maybe (f Type.Poly), Maybe (f Type.Poly), Maybe (f Type.Poly))) -> + IO () +writeUnified dstDir unifiedSigs = do + writePolymorphic dstDir realColumn + (Vector.mapMaybe (Func.mapSnd fst3) unifiedSigs) + (formatClassCall 'S' 'D') + + writePolymorphic dstDir complexColumn + (Vector.mapMaybe (Func.mapSnd snd3) unifiedSigs) + (formatClassCall 'C' 'Z') + + writePolymorphic dstDir genericColumn + (Vector.mapMaybe (Func.mapSnd thd3) unifiedSigs) + formatClassCallRC + + +pathArgument :: + (PathClass.FileDir fd) => + OP.Mod OP.ArgumentFields (Path.AbsRel fd) -> OP.Parser (Path.AbsRel fd) +pathArgument = OP.argument (OP.eitherReader Path.parse) + +optParser :: + OP.Parser + (URL, (Path.AbsRelFile, Path.AbsRelDir, Path.AbsRelDir, Path.AbsRelDir)) +optParser = + App.lift2 (,) + (OP.strOption $ + OP.long "fortran-url" <> + OP.metavar "URL" <> + OP.value "" <> + OP.help "Printf template for URL of online help") $ + App.lift4 (,,,) + (pathArgument $ + OP.metavar "CSV" <> + OP.help "Spreadsheet containing grouped Fortran file names") + (pathArgument $ + OP.metavar "SRCDIR" <> + OP.help "Input directory containing Fortran files") + (pathArgument $ + OP.metavar "FFIDIR" <> + OP.help "Output directory for Haskell FFI modules") + (pathArgument $ + OP.metavar "CARRAYDIR" <> + OP.help "Output directory for Haskell CArray wrapper modules") + +optionInfo :: OP.Parser a -> OP.ParserInfo a +optionInfo parser = + OP.info + (OP.helper <*> parser) + (OP.fullDesc <> + OP.progDesc + "Automated generation of low-level and mid-level bindings for LAPACK") + + +main :: IO () +main = do + (url, (csvFile, srcDir, ffiDir, carrayDir)) <- + OP.execParser $ optionInfo optParser + createDirectoryIfMissing True ffiDir + createDirectoryIfMissing True carrayDir + + (headers, functionSets) <- + either (ioError . userError) return . Csv.decodeByName + =<< BL.readFile (Path.toString csvFile) + + dstFiles <- + fmap (Map.fromList . Fold.toList) $ + for (Vector.drop 1 headers) $ \columnName -> + fmap ((,) columnName) $ + liftA2 (,) + (writeHeader ffiDir columnName Nothing) + (writeHeader carrayDir columnName Nothing) + + sigs <- + for functionSets $ \(FunctionSet name files) -> + fmap ((,) name . Map.mapMaybe id) $ + sequenceA $ + flip Map.mapWithKey files $ \modul file -> do + let srcPath = srcDir file + fmap ((,) srcPath) <$> + processFunction (dstFiles Map.! modul) url name srcPath + + let runUnification dstDir msg select = + writeUnified dstDir =<< + traverse (Func.mapSnd (unifyFunctions msg . fmap (mapSnd select))) sigs + + runUnification ffiDir "Cannot generalize FFI functions." fst + runUnification carrayDir "Cannot generalize CArray functions." snd diff --git a/src/MainSingle.hs b/src/MainSingle.hs new file mode 100644 --- /dev/null +++ b/src/MainSingle.hs @@ -0,0 +1,30 @@ +module Main where + +import qualified Type +import Parser.Signature (Identifier(Identifier)) +import CreateBinding + (Parameter, formatForeignCall, foreignFromParameters, parseHeader) + +import qualified Text.ParserCombinators.Parsec as Parsec + +import qualified System.IO as IO + +import qualified Control.Monad.Trans.Writer as MW +import Control.Applicative ((<$>)) + +import Data.Char (toLower) + + +foreignSig :: + (Identifier, [Parameter], Maybe Type.Mono) -> + ((String, String), Type.Foreign Type.Mono) +foreignSig (Identifier name, params, returnType) = + ((map toLower name, name), foreignFromParameters params returnType) + +main :: IO () +main = + either (IO.hPutStrLn IO.stderr . show) putStr . + Parsec.parse + (formatForeignCall . foreignSig . fst . MW.runWriter <$> parseHeader) + "" + =<< getContents diff --git a/src/Parser/Combinator.hs b/src/Parser/Combinator.hs new file mode 100644 --- /dev/null +++ b/src/Parser/Combinator.hs @@ -0,0 +1,58 @@ +module Parser.Combinator where + +import qualified Text.ParserCombinators.Parsec as Parsec +import Text.ParserCombinators.Parsec (Parser, (<|>)) + +import Control.Monad.HT (void) +import Control.Monad (liftM2) + + +space :: Parser () +space = + void (Parsec.char ' ') + <|> + Parsec.try (Parsec.newline >> continue) + +newline :: Parser () +newline = do + void Parsec.newline + Parsec.notFollowedBy continue + +continue :: Parser () +continue = do + Parsec.skipMany $ Parsec.char ' ' + void $ Parsec.char '$' + +spaces :: Parser () +spaces = Parsec.skipMany space + +garbage :: Parser () +garbage = Parsec.skipMany $ Parsec.noneOf "\n" + +infixl 1 `followedBy` + +followedBy :: Parser a -> Parser () -> Parser a +followedBy p end = do a <- p; end; return a + +oneLine :: Parser a -> Parser a +oneLine p = p `followedBy` newline + +lexeme :: Parser a -> Parser a +lexeme p = p `followedBy` spaces + +identifier :: Parser String +identifier = + lexeme $ + liftM2 (:) Parsec.letter (Parsec.many (Parsec.alphaNum <|> Parsec.char '_')) + +commaSep :: Parser a -> Parser [a] +commaSep = flip Parsec.sepBy (lexeme $ Parsec.char ',') + +commaSep1 :: Parser a -> Parser [a] +commaSep1 = flip Parsec.sepBy1 (lexeme $ Parsec.char ',') + +parens :: Parser a -> Parser a +parens = Parsec.between (lexeme $ Parsec.char '(') (lexeme $ Parsec.char ')') + +keyword :: String -> Parser () +keyword str = void $ lexeme $ Parsec.string str diff --git a/src/Parser/Signature.hs b/src/Parser/Signature.hs new file mode 100644 --- /dev/null +++ b/src/Parser/Signature.hs @@ -0,0 +1,289 @@ +module Parser.Signature ( + Identifier(..), Direction(..), ParamDecl(..), header3_3, header3_4, + ) where + +import qualified Parser.Combinator as Parser +import qualified Type + +import qualified Text.ParserCombinators.Parsec as Parsec +import Text.ParserCombinators.Parsec (Parser, (<|>)) +import Text.Printf (printf) + +import Control.Monad.HT (void) +import Control.Monad (liftM2, liftM3) +import Control.Applicative ((<$>), (<$)) + +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Function (fix) +import Data.Maybe (catMaybes) +import Data.Map (Map) + + +newtype Identifier = Identifier String + +subroutine :: Parser (Identifier, [String], Maybe Type.Mono) +subroutine = do + Parser.spaces + Parsec.optional $ Parsec.try $ Parser.keyword "RECURSIVE" + returnType <- + ((Nothing <$) $ Parsec.try $ Parser.keyword "SUBROUTINE") + <|> + (Parser.lexeme (Just <$> typeIdent) + `Parser.followedBy` + Parser.keyword "FUNCTION") + liftM3 (,,) + (Identifier <$> Parser.identifier) + (Parser.parens $ Parser.commaSep Parser.identifier) + (return returnType) + + +type Mapping = Type.Mapping String Type.Mono + +data ParamDecl = Type Type.Mono [(String, Maybe [String])] | External [String] + +typeIdent :: Parser Type.Mono +typeIdent = + (Type.Logical <$ Parsec.string "LOGICAL") + <|> + (Type.Character <$ + Parsec.try + (Parsec.string "CHARACTER" >> Parsec.optional (Parsec.string "*1"))) + <|> + (Type.Integer <$ Parsec.string "INTEGER") + <|> + (Type.RealSingle <$ Parsec.string "REAL") + <|> + (Parser.lexeme (Parsec.string "DOUBLE") >> + ((Type.RealDouble <$ Parsec.string "PRECISION") + <|> + (Type.ComplexDouble <$ Parsec.string "COMPLEX"))) + <|> + (Parsec.string "COMPLEX" >> + ((Type.ComplexDouble <$ Parsec.string "*16") <|> return Type.ComplexSingle)) + +expression :: Parser String +expression = + fmap concat $ + Parsec.many1 $ + Parsec.many1 Parsec.alphaNum + <|> + fmap return (Parsec.oneOf "+-*/: ") + <|> + (fmap (printf "(%s)") $ + Parsec.between + (Parser.lexeme $ Parsec.char '(') (Parser.lexeme $ Parsec.char ')') + (List.intercalate "," <$> Parser.commaSep1 expression)) + +externalDecl :: Parser [String] +externalDecl = + Parsec.try (Parsec.string "EXTERNAL") + >> + Parser.spaces + >> + Parser.commaSep1 Parser.identifier + +parameterDecl :: Parser ParamDecl +parameterDecl = + Parsec.spaces >> + (fmap External externalDecl + <|> + (liftM2 Type + (Parser.lexeme typeIdent) + (Parser.commaSep $ + liftM2 (,) + Parser.identifier + (Parsec.option Nothing $ + fmap Just $ Parser.parens $ Parser.commaSep1 $ + Parser.lexeme (Parsec.string "*") <|> expression)))) + +data Direction = Input | Output | InputOutput | InputWorkspace | Workspace + deriving (Eq, Show) + +direction3_3 :: Parser Direction +direction3_3 = do + dirs <- Parsec.many1 (Parsec.letter <|> Parsec.char '/' <|> Parsec.char ' ') + case dirs of + "input" -> return Input + "input or output" -> return InputOutput + "input/output" -> return InputOutput + "input/workspace" -> return InputWorkspace + "output" -> return Output + "workspace" -> return Workspace + "workspace/output" -> return Workspace + "input/workspace/output" -> return InputOutput + _ -> fail $ "unknown direction specification: " ++ dirs + +arrayDimensions :: String -> Parser (Maybe [String]) +arrayDimensions commentStart = do + Parser.keyword "array," + (do + Parser.keyword "dimension" + (do + dims <- Parser.parens (Parser.commaSep1 expression) + (Nothing <$ + Parsec.try + (Parser.keyword "if" <|> + (Parser.keyword ('\n':commentStart) >> Parser.keyword "if"))) + <|> return (Just dims)) + <|> return Nothing) + <|> + return Nothing + +optionalDimensions :: String -> Parser (Maybe Mapping) +optionalDimensions commentStart = + (fmap Type.Array <$> arrayDimensions commentStart) + <|> + return (Just Type.Scalar) + +{- +LOGICAL FUNCTION of one COMPLEX argument +-} +callback :: Parser (Int, Type.Mono, Type.Mono) +callback = do + returnType <- Parser.lexeme typeIdent + Parser.keyword "FUNCTION" + Parser.keyword "of" + let arguments n nStr argStr = do + Parsec.try $ Parser.keyword nStr + typ <- Parser.lexeme typeIdent + Parser.keyword argStr + return (n,typ) + (n,argType) <- + arguments 1 "one" "argument" <|> + arguments 2 "two" "arguments" <|> + arguments 3 "three" "arguments" + return (n,argType,returnType) + +parameterComment3_3 :: Parser (String, (Direction, Type.Mono, Maybe Mapping)) +parameterComment3_3 = do + void $ Parser.lexeme $ Parsec.char '*' + liftM2 (,) Parser.identifier $ + liftM3 (,,) + (Parser.parens direction3_3) (Parser.lexeme typeIdent) + (optionalDimensions "*") + `Parser.followedBy` + Parser.garbage + +anyComment :: Parser () +anyComment = do + void $ Parsec.char '*' + Parser.garbage + +commentOrBlank :: Parser () +commentOrBlank = Parser.oneLine $ anyComment <|> return () + + +header3_3 :: + Parser + ((Identifier, [String], Maybe Type.Mono), [ParamDecl], + Map String (Direction, Type.Mono, Maybe Mapping)) +header3_3 = do + prototype <- Parser.oneLine subroutine + Parsec.skipMany commentOrBlank + Parsec.optional $ Parsec.try $ Parser.oneLine $ do + Parser.spaces + Parser.keyword "IMPLICIT" + Parser.keyword "NONE" + Parsec.skipMany commentOrBlank + paramTypes <- + fix $ \loop -> + liftM2 (:) (Parser.oneLine parameterDecl) $ + fix $ \loopCmt -> + ([] <$ Parsec.try (Parsec.lookAhead parameterComment3_3)) + <|> + (commentOrBlank >> loopCmt) + <|> + loop + paramDirs <- + Parsec.many $ + (Just <$> Parsec.try (Parser.oneLine parameterComment3_3)) + <|> + (Nothing <$ commentOrBlank) + return (prototype, paramTypes, Map.fromList $ catMaybes paramDirs) + + +direction3_4 :: Parser (Bool -> Direction) +direction3_4 = do + dirs <- Parsec.many1 (Parsec.letter <|> Parsec.char ',') + case dirs of + "in" -> return $ \work -> if work then InputWorkspace else Input + "in,out" -> return $ const InputOutput + "out" -> return $ \work -> if work then Workspace else Output + _ -> fail $ "unknown direction specification: " ++ dirs + +{- +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +-} +parameterComment3_4 :: Parser (String, (Direction, Type.Mono, Maybe Mapping)) +parameterComment3_4 = do + let doxyCmt = void $ Parser.lexeme $ Parsec.string "*>" + void $ Parsec.try $ doxyCmt >> Parsec.string "\\param" + dirFromWork <- + Parser.lexeme $ + Parsec.between (Parsec.char '[') (Parsec.char ']') direction3_4 + name <- Parser.identifier + void $ Parsec.newline + let dir = dirFromWork $ List.isSuffixOf "WORK" name + + doxyCmt >> Parsec.string "\\verbatim" >> void Parsec.newline + + doxyCmt + void $ Parser.lexeme $ Parsec.string name + void $ Parser.lexeme $ Parsec.string "is" + + (typ,dims) <- + Parser.oneLine $ + (do + Parsec.try $ Parser.keyword "a" + (n,argType,returnType) <- callback + return (returnType, Just $ Type.Function n argType)) + <|> + (liftM2 (,) (Parser.lexeme typeIdent) (optionalDimensions "*>") + `Parser.followedBy` + Parser.garbage) + + return (name, (dir,typ,dims)) + + +header3_4 :: + Parser + ((Identifier, [String], Maybe Type.Mono), [ParamDecl], + Map String (Direction, Type.Mono, Maybe Mapping)) +header3_4 = do + void $ fix $ \loop -> + (Parsec.try $ Parser.oneLine $ + Parser.lexeme (Parsec.string "*") >> Parsec.string "Arguments:") + <|> + (commentOrBlank >> loop) + void $ Parser.oneLine $ + Parser.lexeme (Parsec.string "*") >> Parsec.string "==========" + void $ Parser.oneLine $ Parser.lexeme (Parsec.string "*") + paramDirs <- + Parsec.many $ + (Just <$> parameterComment3_4) + <|> + (Nothing <$ + Parsec.try (Parser.oneLine (Parsec.string "*>" >> Parser.garbage))) + Parsec.skipMany commentOrBlank + prototype <- Parser.oneLine subroutine + Parsec.skipMany commentOrBlank + Parsec.optional $ Parsec.try $ Parser.oneLine $ do + Parser.spaces + Parser.keyword "IMPLICIT" <|> Parser.keyword "implicit" + Parser.keyword "NONE" <|> Parser.keyword "none" + Parsec.skipMany commentOrBlank + paramTypes <- + fix $ \loop -> + liftM2 (:) (Parser.oneLine parameterDecl) $ + fix $ \loopCmt -> + (Parsec.try $ Parser.oneLine $ + [] <$ (Parser.lexeme (Parsec.string "*") >> + Parsec.string "==================" >> Parser.garbage)) + <|> + (commentOrBlank >> loopCmt) + <|> + loop + return (prototype, paramTypes, Map.fromList $ catMaybes paramDirs) diff --git a/src/Type.hs b/src/Type.hs new file mode 100644 --- /dev/null +++ b/src/Type.hs @@ -0,0 +1,250 @@ +module Type where + +import qualified Data.Foldable as Fold +import qualified Data.List.Match as Match +import qualified Data.List as List +import Data.Foldable (Foldable, foldMap) +import Data.Monoid (mempty, (<>)) +import Data.Maybe.HT (toMaybe) +import Data.Tuple.HT (fst3) + +import Control.Monad (mfilter) +import Control.Applicative (liftA2, liftA3, (<$>), (<*>)) + +import Text.Printf (printf) + + +data + Mono = + Logical | Character | Integer | + RealSingle | RealDouble | ComplexSingle | ComplexDouble + deriving (Eq, Show) + + +data Poly = Variable Var | Mono Mono + deriving (Eq) + +data Var = Real | Complex + deriving (Eq) + +isVar :: Poly -> Bool +isVar (Variable _) = True +isVar (Mono _) = False + + +unifyPrecision :: Mono -> Mono -> Maybe Poly +unifyPrecision RealSingle RealDouble = Just $ Variable Real +unifyPrecision ComplexSingle ComplexDouble = Just $ Variable Complex +unifyPrecision floatType doubleType = + toMaybe (floatType == doubleType) $ Mono floatType + +unifyRealComplex :: Poly -> Poly -> Maybe Poly +unifyRealComplex (Variable real) (Variable complex) = + toMaybe ((real, complex) == (Real, Complex)) $ Variable Real +unifyRealComplex realType complexType = + toMaybe (realType == complexType) realType + + + +class Foldable f => Unification f where + unify :: (a -> b -> Maybe c) -> f a -> f b -> Maybe (f c) + +instance Unification [] where + unify uni as bs = + mfilter (const $ Match.equalLength as bs) $ sequence $ zipWith uni as bs + +instance Unification Maybe where + unify uni ma mb = + case (ma,mb) of + (Nothing, Nothing) -> Just Nothing + (Just a, Just b) -> Just <$> uni a b + _ -> Nothing + +unifyEq :: (a -> a -> Bool) -> a -> a -> Maybe a +unifyEq eq a b = toMaybe (eq a b) a + + +data Pointer typ = Ptr typ | FunPtr Int typ typ + +instance Foldable Pointer where + foldMap f (Ptr typ) = f typ + foldMap f (FunPtr _n param ret) = f param <> f ret + +instance Unification Pointer where + unify uni (Ptr aTyp) (Ptr bTyp) = Ptr <$> uni aTyp bTyp + unify uni (FunPtr an aParam aReturn) (FunPtr bn bParam bReturn) = + FunPtr + <$> unifyEq (==) an bn <*> uni aParam bParam <*> uni aReturn bReturn + unify _ _ _ = Nothing + + +data Foreign typ = Foreign [Pointer typ] (Maybe typ) + +instance Foldable Foreign where + foldMap f (Foreign params returnType) = + foldMap (foldMap f) params <> foldMap f returnType + +instance Unification Foreign where + unify uni (Foreign aParams aReturn) (Foreign bParams bReturn) = + liftA2 Foreign + (unify (unify uni) aParams bParams) (unify uni aReturn bReturn) + +unifySignature :: + (Unification f) => (a -> b -> Maybe Poly) -> f a -> f b -> Maybe (f Poly) +unifySignature uni floatSig doubleSig = + mfilter (Fold.any isVar) $ unify uni floatSig doubleSig + + +data Wrapper typ = + Wrapper + [(typ, Mapping String typ, Bool)] (Maybe typ) [(typ, Mapping String typ)] + +instance Foldable Wrapper where + foldMap f (Wrapper inputs returnType outputs) = + foldMap (f.fst3) inputs <> foldMap f returnType <> foldMap (f.fst) outputs + +instance Unification Wrapper where + unify uni + (Wrapper aInputs aReturn aOutputs) (Wrapper bInputs bReturn bOutputs) = + + liftA3 Wrapper + (unify + (\(aType,aDims,aMut) (bType,bDims,bMut) -> + liftA3 (,,) + (uni aType bType) + (unify uni aDims bDims) + (unifyEq (==) aMut bMut)) + aInputs bInputs) + (unify uni aReturn bReturn) + (unify + (\(aType,aDims) (bType,bDims) -> + liftA2 (,) + (uni aType bType) + (unify uni aDims bDims)) + aOutputs bOutputs) + + + +class Format typ where + format :: typ -> String + formatParameter :: typ -> String + + +formatCallback :: Int -> Mono -> Mono -> String +formatCallback n param ret = + concat (replicate n (formatPtr param ++ " -> ")) + ++ + "IO " ++ format ret + +formatTuple :: [String] -> String +formatTuple elems = + case elems of + [] -> "()" + [x] -> x + _ -> "(" ++ List.intercalate "," elems ++ ")" + +formatIndex :: [String] -> String +formatIndex = formatTuple . flip Match.replicate "Int" + +formatPtr :: (Format typ) => typ -> String +formatPtr typ = "Ptr " ++ format typ + +formatFunPtr :: (Format typ) => Int -> typ -> typ -> String +formatFunPtr n param ret = + printf "FunPtr (%sIO %s)" + (concat $ replicate n $ formatPtr param ++ " -> ") (format ret) + +formatArray :: (Format typ) => String -> typ -> Mapping String typ -> String +formatArray array elm mapping = + case mapping of + Scalar -> formatParameter elm + Array dims -> array ++ " " ++ formatIndex dims ++ " " ++ format elm + Function n param -> formatFunPtr n param elm + +instance Format Mono where + format typ = + case typ of + Logical -> "Bool" + Character -> "CChar" + Integer -> "CInt" + RealSingle -> "Float" + RealDouble -> "Double" + ComplexSingle -> "(Complex Float)" + ComplexDouble -> "(Complex Double)" + + formatParameter typ = + case typ of + Logical -> "Bool" + Character -> "Char" + Integer -> "Int" + RealSingle -> "Float" + RealDouble -> "Double" + ComplexSingle -> "Complex Float" + ComplexDouble -> "Complex Double" + + +formatVariable :: Var -> String +formatVariable Real = "a" +formatVariable Complex = "(Complex a)" + +formatVarFunPtr :: (Format typ) => Int -> typ -> Var -> String +formatVarFunPtr n param ret = + printf "FunPtr (%sIO %s)" + (concat $ replicate n $ formatPtr param ++ " -> ") (formatVariable ret) + +instance Format Poly where + format (Variable var) = formatVariable var + format (Mono typ) = format typ + + formatParameter (Variable var) = formatVariable var + formatParameter (Mono typ) = formatParameter typ + + +formatForeignParam :: Format a => Pointer a -> String +formatForeignParam pointer = + case pointer of + Ptr typ -> formatPtr typ + FunPtr n param ret -> formatFunPtr n param ret + +formatForeign :: Format a => Foreign a -> String +formatForeign (Foreign params returnType) = + concatMap ((++ " -> ") . formatForeignParam) params ++ + "IO " ++ maybe "()" format returnType + + + +data Mapping dim typ = Scalar | Array [dim] | Function Int typ + deriving (Eq) + +instance Foldable (Mapping dim) where + foldMap f m = + case m of + Scalar -> mempty + Array _ -> mempty + Function _ param -> f param + +instance Unification (Mapping dim) where + unify _uni Scalar Scalar = Just Scalar + unify _uni (Array aDims) (Array bDims) = + Array <$> unifyEq Match.equalLength aDims bDims + unify uni (Function an aParam) (Function bn bParam) = + Function <$> unifyEq (==) an bn <*> uni aParam bParam + unify _uni _ _ = Nothing + +mapMappings :: ([dim0] -> [dim1]) -> Mapping dim0 typ -> Mapping dim1 typ +mapMappings f m = + case m of + Scalar -> Scalar + Array dims -> Array $ f dims + Function n param -> Function n param + +mapMapping :: (dim0 -> dim1) -> Mapping dim0 typ -> Mapping dim1 typ +mapMapping f = mapMappings (fmap f) + +isScalar :: Mapping dim typ -> Bool +isScalar Scalar = True +isScalar _ = False + +maybeArray :: Mapping dim typ -> Maybe [dim] +maybeArray (Array dims) = Just dims +maybeArray _ = Nothing