qq to gfortran (annotation) (annotation)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
{-# LANGUAGE QuasiQuotes #-}
module Testabc where
import RlangQQ
import DwarfQQ

import qualified Data.Vector.Storable as V

[fortran|
subroutine test(a,b)
  real*8 b(3)
  b(:) = a+b
end

subroutine cspline(m,x,n,xs,ys)
  integer,       intent(in) :: m,n
  real (kind=8), intent(in) :: xs(n),ys(n)
  real (kind=8), intent(inout) :: x(m)

  integer, parameter :: maxK = 5
  real (kind=8) :: s(n,6), break(n), coef(n,maxK)

  call tautsp (xs,ys, n, 0, s, break, coef, l, k, iflag )
  do i=1,m
  x(i) = ppvalu (break, coef, l, k, x(i), 0)
  end do
end

|]

main = do
  so <- dlopen "./test.so" [RTLD_NOW]

  do
    b <- V.thaw (V.fromList [1,2,3])
    test so 3 b
    print =<< V.freeze b

  xs <- V.thaw (V.fromList [1,2,3,4,5,6])
  ys <- V.thaw (V.fromList [5,4,5,7,6,5.5])

  let xi = V.fromList [1, 1.01 .. 6]
  yi <- V.thaw xi

  cspline so (fromIntegral (V.length xi)) yi 6 xs ys
  yi <- V.freeze yi

  [r| library(ggplot2)
      df <- data.frame(x = $(xi), y = $(yi))
      ggplot(df, aes(x,y)) + geom_path()
      |]

  dlclose so

-----------------------------------------------------------------
--      DwarfQQ.hs                                             --
-----------------------------------------------------------------
{-# LANGUAGE TemplateHaskell #-}
{- | a quasiquote to contain a foreign language (gfortran) and generate
haskell functions that use libffi to call those functions/procedures.

-}
module DwarfQQ
  (fortran,
   module System.Posix.DynamicLinker,
  ) where

import Control.Applicative
import Control.Monad
import Data.Dwarf
import Data.Dwarf.ADT
import Data.Dwarf.Elf
import Data.Int
import Data.Maybe
import Data.Word
import Foreign.LibFFI
import Foreign.Marshal
import Foreign.Ptr
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import qualified Data.Vector.Storable.Mutable as VM
import System.Cmd
import System.Posix.DynamicLinker

{- | includes
http://people.sc.fsu.edu/~%20jburkardt/f_src/pppack/pppack.html

-}
fortran = QuasiQuoter {
  quoteExp = error "fortran",
  quotePat = error "fortran",
  quoteType = error "fortran",
  quoteDec = \s -> do
  sps <- runIO $ do
    writeFile "test.f90" s
    system "test -e 'pppack.a' || gfortran -O3 -fPIC pppack.f90 -c -o pppack.a"
    system "gfortran -fbounds-check -fdefault-real-8 -O3 -fPIC -g -shared pppack.a test.f90 -o test.so"
    (Dwarf as,b) <- parseElfDwarfADT LittleEndian "test.so"
    return [ sp | Boxed _ a <- as, Boxed _ (DefSubprogram sp) <- cuDefs a,
                  subprogExternal sp ]
  sequence [ do
            dlName <- newName "dlName"
            funD (mkName (subprogName sp))
                [clause [varP dlName] (normalB (callSubprogram sp dlName)) []]
    | sp <- sps ]
  }


mangle :: String -> String
mangle x = x ++ "_"

callSubprogram :: Subprogram -> Name -> ExpQ
callSubprogram sp dlName = do
  ps <- zipWithM (\(Boxed _ x) n -> do
                  n' <- newName (fromMaybe ("x"++ show n) (formalParamName x))
                  return (n', x))
      (subprogFormalParameters sp)
      [1 .. ]
  lamE (map (varP . fst) ps) $
    [| do
        fn <- dlsym $(varE dlName) $(lift (mangle (subprogName sp)))
        $(foldr
            (\(n',FormalParameter { formalParamType = TypeRef (Boxed _ ty) }) accum ->
                  dtMarshal ty n' accum)
            [| callFFI fn retVoid $(listE (map (varE . fst) ps)) |]
            ps)
      |]


dtMarshal :: DefType -> Name -> ExpQ -> ExpQ
dtMarshal (DefArrayType (ArrayType { atSubrangeType = [Boxed _ (SubrangeType up rt)],
                   atType = TypeRef (Boxed _ (DefBaseType at)) }))
          n x =
      [| VM.unsafeWith $(varE n) ($(lamE [varP n] x)
          . argPtr . flip asTypeOf (undefined :: Ptr $(conT (btToHS at)))) |]
dtMarshal (DefBaseType dt) n x =
    [| new ($(varE n) :: $(conT (btToHS dt))) >>=
        \ m -> $(lamE [varP n] x) (argPtr m) <* free m |]

dtToHS :: DefType -> TypeQ
dtToHS (DefArrayType (ArrayType { atSubrangeType = [Boxed _ (SubrangeType up rt)],
                   atType = TypeRef (Boxed _ at) })) =
      [t| Ptr $(dtToHS at) |]
dtToHS (DefBaseType dt) = conT (btToHS dt)

btToHS :: BaseType -> Name
btToHS (BaseType { btByteSize = n, btEncoding = enc }) |
  enc `elem` [DW_ATE_unsigned, DW_ATE_unsigned_char] = case n of
    8 -> ''Word64
    4 -> ''Word32
    2 -> ''Word16
    1 -> ''Word8
btToHS (BaseType { btByteSize = n, btEncoding = enc }) |
  enc `elem` [DW_ATE_signed, DW_ATE_signed_char] = case n of
    8 -> ''Int64
    4 -> ''Int32
    2 -> ''Int16
    1 -> ''Int8
btToHS (BaseType { btByteSize = n, btEncoding = enc }) |
  enc `elem` [DW_ATE_float] = case n of
    8 -> ''Double
    4 -> ''Float
{-
  = DW_ATE_address
  | DW_ATE_boolean
  | DW_ATE_complex_float
  | DW_ATE_imaginary_float
  | DW_ATE_packed_decimal
  | DW_ATE_numeric_string
  | DW_ATE_edited
  | DW_ATE_signed_fixed
  | DW_ATE_unsigned_fixed
  | DW_ATE_decimal_float
-}