0 | module Compiler.Scheme.Gambit

  2 | import Compiler.Common

  3 | import Compiler.CompileExpr

  4 | import Compiler.Generated

  5 | import Compiler.Opts.ToplevelConstants

  6 | import Compiler.Scheme.Common

  8 | import Core.Directory

  9 | import Protocol.Hex

 10 | import Libraries.Utils.Path

 11 | import Libraries.Data.String.Builder

 13 | import Data.Maybe

 14 | import Data.SortedSet

 16 | import Idris.Env

 17 | import Idris.Syntax

 19 | import System

 20 | import System.Directory

 22 | %default covering

 25 | findGSI : IO (List String)

 26 | findGSI =

 27 |   do env <- idrisGetEnv "GAMBIT_GSI"

 28 |      pure $ maybe ["/usr/bin/env", "gsi"] singleton env

 31 | findGSC : IO (List String)

 32 | findGSC =

 33 |   do env <- idrisGetEnv "GAMBIT_GSC"

 34 |      pure $ maybe ["/usr/bin/env", "gsc"] singleton env

 36 | findGSCBackend : IO (List String)

 37 | findGSCBackend =

 38 |   do env <- idrisGetEnv "GAMBIT_GSC_BACKEND"

 39 |      pure $ case env of

 40 |               Nothing => []

 41 |               Just e => ["-cc", e]

 43 | schHeader : Builder

 44 | schHeader = fromString """

 55 | showGambitChar : Char -> Builder -> Builder

 56 | showGambitChar '\\' acc = "\\\\" ++ acc

 57 | showGambitChar c acc

 58 |    = if ord c < 32 -- XXX

 59 |         then fromString ("\\x" ++ fromString (asHex (cast c)) ++ ";") ++ acc

 60 |         else char c ++ acc

 62 | showGambitString : List Char -> Builder -> Builder

 63 | showGambitString [] acc = acc

 64 | showGambitString ('"' :: cs) acc = "\\\"" ++ showGambitString cs acc

 65 | showGambitString (c :: cs) acc = showGambitChar c $ showGambitString cs acc

 67 | gambitString : String -> Builder

 68 | gambitString cs = "\"" ++ showGambitString (unpack cs) "\""

 70 | handleRet : CFType -> Builder -> Builder

 71 | handleRet CFUnit op = op ++ " " ++ mkWorld (schConstructor gambitString (UN $ Basic "") (Just 0) [])

 72 | handleRet _ op = mkWorld op

 74 | getFArgs : NamedCExp -> Core (List (NamedCExp, NamedCExp))

 75 | getFArgs (NmCon fc _ _ (Just 0) _) = pure []

 76 | getFArgs (NmCon fc _ _ (Just 1) [ty, val, rest]) = pure $ (ty, val) :: !(getFArgs rest)

 77 | getFArgs arg = throw (GenericMsg (getFC arg) ("Badly formed c call argument list " ++ show arg))

 79 | gambitPrim : SortedSet Name -> LazyExprProc -> Nat -> ExtPrim -> List NamedCExp -> Core Builder

 80 | gambitPrim cs schLazy i GetField [NmPrimVal _ (Str s), _, _, struct,

 81 |                        NmPrimVal _ (Str fld), _]

 82 |     = do structsc <- schExp cs (gambitPrim cs schLazy) gambitString schLazy 0 struct

 83 |          pure $ "(" ++ fromString s ++ "-" ++ fromString fld ++ " " ++ structsc ++ ")"

 84 | gambitPrim cs schLazy i GetField [_,_,_,_,_,_]

 85 |     = pure "(error \"bad getField\")"

 86 | gambitPrim cs schLazy i SetField [NmPrimVal _ (Str s), _, _, struct,

 87 |                        NmPrimVal _ (Str fld), _, val, world]

 88 |     = do structsc <- schExp cs (gambitPrim cs schLazy) gambitString schLazy 0 struct

 89 |          valsc <- schExp cs (gambitPrim cs schLazy) gambitString schLazy 0 val

 90 |          pure $ mkWorld $

 91 |               "(" ++ fromString s ++ "-" ++ fromString fld ++ "-set! " ++ structsc ++ " " ++ valsc ++ ")"

 92 | gambitPrim cs schLazy i SetField [_,_,_,_,_,_,_,_]

 93 |     = pure "(error \"bad setField\")"

 94 | gambitPrim cs schLazy i SysCodegen []

 95 |     = pure $ "\"gambit\""

 96 | gambitPrim cs schLazy i prim args

 97 |     = schExtCommon cs (gambitPrim cs schLazy) gambitString schLazy i prim args

100 | data Loaded : Type where

103 | data Structs : Type where

105 | notWorld : CFType -> Bool

106 | notWorld CFWorld = False

107 | notWorld _ = True

109 | cType : FC -> CFType -> Core Builder

110 | cType fc CFUnit = pure "void"

111 | cType fc CFInt = pure "int"

112 | cType fc CFString = pure "char *"

113 | cType fc CFDouble = pure "double"

114 | cType fc CFChar = pure "char"

115 | cType fc CFPtr = pure "void *"

116 | cType fc (CFIORes t) = cType fc t

117 | cType fc (CFStruct n t) = pure $ "struct " ++ fromString n

118 | cType fc (CFFun s t) = funTySpec [s] t

119 |   where

120 |     funTySpec : List CFType -> CFType -> Core Builder

121 |     funTySpec args (CFFun CFWorld t) = funTySpec args t

122 |     funTySpec args (CFFun s t) = funTySpec (s :: args) t

123 |     funTySpec args retty

124 |         = do rtyspec <- cType fc retty

125 |              argspecs <- traverse (cType fc) (reverse . filter notWorld $ args)

126 |              pure $ rtyspec ++ " (*)(" ++ sepBy ", " argspecs ++ ")"

127 | cType fc t = throw (GenericMsg fc ("Can't pass argument of type " ++ show t ++

128 |                        " to foreign function"))

130 | cftySpec : FC -> CFType -> Core Builder

131 | cftySpec fc CFUnit = pure "void"

132 | cftySpec fc CFInt = pure "int"

133 | cftySpec fc CFInt8 = pure "char"

134 | cftySpec fc CFInt16 = pure "short"

135 | cftySpec fc CFInt32 = pure "int"

136 | cftySpec fc CFInt64 = pure "long"

137 | cftySpec fc CFUnsigned8 = pure "unsigned-char"

138 | cftySpec fc CFUnsigned16 = pure "unsigned-short"

139 | cftySpec fc CFUnsigned32 = pure "unsigned-int"

140 | cftySpec fc CFUnsigned64 = pure "unsigned-long"

141 | cftySpec fc CFString = pure "UTF-8-string"

142 | cftySpec fc CFDouble = pure "double"

143 | cftySpec fc CFChar = pure "char"

144 | cftySpec fc CFPtr = pure "(pointer void)"

145 | cftySpec fc (CFIORes t) = cftySpec fc t

146 | cftySpec fc (CFStruct n t) = pure $ fromString n ++ "*/nonnull"

147 | cftySpec fc (CFFun s t) = funTySpec [s] t

148 |   where

149 |     funTySpec : List CFType -> CFType -> Core Builder

150 |     funTySpec args (CFFun CFWorld t) = funTySpec args t

151 |     funTySpec args (CFFun s t) = funTySpec (s :: args) t

152 |     funTySpec args retty

153 |         = do rtyspec <- cftySpec fc retty

154 |              argspecs <- traverse (cftySpec fc) (reverse . filter notWorld $ args)

155 |              pure $ "(function (" ++ sepBy " " argspecs ++ ") " ++ rtyspec ++ ")"

156 | cftySpec fc t = throw (GenericMsg fc ("Can't pass argument of type " ++ show t ++

157 |                          " to foreign function"))

160 | record CCallbackInfo where

161 |   constructor MkCCallbackInfo

162 |   schemeArgName : Builder

163 |   schemeWrapName : String

164 |   callbackBody : Builder

165 |   argTypes : List Builder

166 |   retType : Builder

168 | record CWrapperDefs where

169 |   constructor MkCWrapperDefs

170 |   setBox : Builder

171 |   boxDef : Builder

172 |   cWrapDef : Builder

174 | cCall : {auto c : Ref Ctxt Defs} ->

175 |         {auto l : Ref Loaded (List String)} ->

176 |         FC -> (cfn : String) -> (fnWrapName : String -> String) -> (clib : String) ->

177 |         List (Name, CFType) -> CFType -> Core (Builder, Builder)

178 | cCall fc cfn fnWrapName clib args ret

179 |     = do -- loaded <- get Loaded

180 |          -- lib <- if clib `elem` loaded

181 |          --           then pure ""

182 |          --           else do (fname, fullname) <- locate clib

183 |          --                   copyLib (fname, fullname)

184 |          --                   put Loaded (clib :: loaded)

185 |          --                   pure ""

186 |          argTypes <- traverse (cftySpec fc . snd) args

187 |          retType <- cftySpec fc ret

189 |          argsInfo <- traverse buildArg args

190 |          argCTypes <- traverse (cType fc . snd) args

191 |          retCType <- cType fc ret

193 |          let cWrapperDefs = map buildCWrapperDefs $ mapMaybe snd argsInfo

194 |          let cFunWrapDeclaration = buildCFunWrapDeclaration (fromString cfn) retCType argCTypes

195 |          let wrapDeclarations = cFunWrapDeclaration

196 |                                 ++ concatMap (.boxDef) cWrapperDefs

197 |                                 ++ concatMap (.cWrapDef) cWrapperDefs

199 |          let setBoxes = concatMap (.setBox) cWrapperDefs

200 |          let call = " ((c-lambda (" ++ sepBy " " argTypes ++ ") "

201 |                       ++ retType ++ " " ++ showB cfn ++ ") "

202 |                       ++ sepBy " " (map fst argsInfo) ++ ")"

203 |          let body = setBoxes ++ "\n" ++ call

205 |          pure $ case ret of -- XXX

206 |                      CFIORes _ => (handleRet ret body, wrapDeclarations)

207 |                      _ => (body, wrapDeclarations)

208 |   where

209 |     mkNs : Int -> List CFType -> List (Maybe Builder)

210 |     mkNs i [] = []

211 |     mkNs i (CFWorld :: xs) = Nothing :: mkNs i xs

212 |     mkNs i (x :: xs) = Just (fromString $ "cb" ++ show i) :: mkNs (i + 1) xs

214 |     applyLams : Builder -> List (Maybe Builder) -> Builder

215 |     applyLams n [] = n

216 |     applyLams n (Nothing :: as) = applyLams ("(" ++ n ++ " #f)") as

217 |     applyLams n (Just a :: as) = applyLams ("(" ++ n ++ " " ++ a ++ ")") as

219 |     replaceChar : Char -> Char -> String -> String

220 |     replaceChar old new = pack . replaceOn old new . unpack

222 |     buildCWrapperDefs : CCallbackInfo -> CWrapperDefs

223 |     buildCWrapperDefs (MkCCallbackInfo arg schemeWrap callbackStr argTypes retType) =

224 |       let box = fromString $ schemeWrap ++ "-box"

225 |           setBox = "\n (set-box! " ++ box ++ " " ++ callbackStr ++ ")"

226 |           cWrapName = replaceChar '-' '_' schemeWrap

227 |           boxDef = "\n(define " ++ box ++ " (box #f))\n"

229 |           args =

230 |             if length argTypes > 0

231 |               then " " ++ (sepBy " " $ map (\i => fromString $ "farg-" ++ show i) [0 .. (natToInteger $ length argTypes) - 1])

232 |               else ""

234 |           cWrapDef : Builder =

235 |             "\n(c-define " ++

236 |             "(" ++ fromString schemeWrap ++ args ++ ")" ++

237 |             " (" ++ sepBy " " argTypes ++ ")" ++

238 |             " " ++ retType ++

239 |             " \"" ++ fromString cWrapName ++ "\"" ++ " \"\"" ++

240 |             "\n ((unbox " ++ box ++ ")" ++ args ++ ")" ++

241 |             "\n)\n"

242 |       in MkCWrapperDefs setBox boxDef cWrapDef

244 |     buildCFunWrapDeclaration : Builder -> Builder -> List Builder -> Builder

245 |     buildCFunWrapDeclaration name ret args =

246 |       "\n(c-declare #<<c-declare-end\n" ++

247 |       ret ++ " " ++ name ++ "(" ++ sepBy ", " args ++ ");" ++

248 |       "\nc-declare-end\n)\n"

250 |     mkFun : List CFType -> CFType -> Builder -> Builder

251 |     mkFun args ret n

252 |         = let argns = mkNs 0 args in

253 |               "(lambda (" ++ sepBy " " (mapMaybe id argns) ++ ") "

254 |               ++ (applyLams n argns ++ ")")

256 |     callback : Builder -> List CFType -> CFType -> Core (Builder, List Builder, Builder)

257 |     callback n args (CFFun s t) = callback n (s :: args) t

258 |     callback n args_rev retty

259 |         = do let args = reverse args_rev

260 |              argTypes <- traverse (cftySpec fc) (filter notWorld args)

261 |              retType <- cftySpec fc retty

262 |              pure (mkFun args retty n, argTypes, retType)

264 |     buildArg : (Name, CFType) -> Core (Builder, Maybe CCallbackInfo)

265 |     buildArg (n, CFFun s t) = do

266 |       let arg = schName n

267 |       let schemeWrap = fnWrapName $ build arg

268 |       (callbackBody, argTypes, retType) <- callback arg [s] t

269 |       pure (fromString schemeWrap, Just $ MkCCallbackInfo arg schemeWrap callbackBody argTypes retType)

270 |     buildArg (n, _) = pure (schName n, Nothing)

272 | schemeCall : FC -> (sfn : String) ->

273 |              List Name -> CFType -> Core Builder

274 | schemeCall fc sfn argns ret

275 |     = let call = "(" ++ fromString sfn ++ " " ++ sepBy " " (map schName argns) ++ ")" in

276 |           case ret of

277 |                CFIORes _ => pure $ mkWorld call

278 |                _ => pure call

283 | useCC : {auto c : Ref Ctxt Defs} ->

284 |         {auto l : Ref Loaded (List String)} ->

285 |         FC -> List String -> List (Name, CFType) -> CFType -> Core (Maybe String, Builder, Builder)

286 | useCC fc ccs args ret

287 |     = case parseCC ["scheme,gambit", "scheme", "C"] ccs of

288 |            Nothing => throw (NoForeignCC fc ccs)

289 |            Just ("scheme,gambit", [sfn]) => pure (Nothing, !(schemeCall fc sfn (map fst args) ret), "")

290 |            Just ("scheme", [sfn]) => pure (Nothing, !(schemeCall fc sfn (map fst args) ret), "")

291 |            Just ("C", [cfn, clib]) => do

292 |                (call, decl) <- cCall fc cfn (fnWrapName cfn) clib args ret

293 |                pure (Just clib, call, decl)

294 |            Just ("C", [cfn, clib, chdr]) => do

295 |                (call, decl) <- cCall fc cfn (fnWrapName cfn) clib args ret

296 |                pure (Just clib, call, decl)

297 |            _ => throw (NoForeignCC fc ccs)

298 |   where

299 |     fnWrapName : String -> String -> String

300 |     fnWrapName cfn schemeArgName = schemeArgName ++ "-" ++ fromString cfn ++ "-cFunWrap"

304 | mkArgs : Int -> List CFType -> List (Name, Bool)

305 | mkArgs i [] = []

306 | mkArgs i (CFWorld :: cs) = (MN "farg" i, False) :: mkArgs i cs

307 | mkArgs i (c :: cs) = (MN "farg" i, True) :: mkArgs (i + 1) cs

309 | mkStruct : {auto s : Ref Structs (List String)} ->

310 |            CFType -> Core Builder

311 | mkStruct (CFStruct n flds)

312 |     = do defs <- traverse mkStruct (map snd flds)

313 |          strs <- get Structs

314 |          if n `elem` strs

315 |             then pure (concat defs)

316 |             else do put Structs (n :: strs)

317 |                     pure $ concat defs ++ "(define-c-struct " ++ fromString n ++ " "

318 |                            ++ sepBy " " !(traverse showFld flds) ++ ")\n"

319 |   where

320 |     showFld : (String, CFType) -> Core Builder

321 |     showFld (n, ty) = pure $ "(" ++ fromString n ++ " " ++ !(cftySpec emptyFC ty) ++ ")"

322 | mkStruct (CFIORes t) = mkStruct t

323 | mkStruct (CFFun a b) = [| mkStruct a ++ mkStruct b |]

324 | mkStruct _ = pure ""

326 | schFgnDef : {auto c : Ref Ctxt Defs} ->

327 |             {auto l : Ref Loaded (List String)} ->

328 |             {auto s : Ref Structs (List String)} ->

329 |             FC -> Name -> NamedDef -> Core (Maybe String, Builder)

330 | schFgnDef fc n (MkNmForeign cs args ret)

331 |     = do let argns = mkArgs 0 args

332 |          let allargns = map fst argns

333 |          let useargns = map fst (filter snd argns)

334 |          argStrs <- traverse mkStruct args

335 |          retStr <- mkStruct ret

336 |          (lib, body, wrapDeclarations) <- useCC fc cs (zip useargns args) ret

337 |          defs <- get Ctxt

338 |          pure (lib,

339 |                 concat argStrs ++ retStr ++

340 |                 wrapDeclarations ++

341 |                 "(define " ++ schName !(full (gamma defs) n) ++

342 |                 " (lambda (" ++ sepBy " " (map schName allargns) ++ ") " ++

343 |                 body ++ "))\n")

344 | schFgnDef _ _ _ = pure (Nothing, "")

346 | getFgnCall : {auto c : Ref Ctxt Defs} ->

347 |              {auto l : Ref Loaded (List String)} ->

348 |              {auto s : Ref Structs (List String)} ->

349 |              (Name, FC, NamedDef) -> Core (Maybe String, Builder)

350 | getFgnCall (n, fc, d) = schFgnDef fc n d

352 | compileToSCM : Ref Ctxt Defs ->

353 |                ClosedTerm -> (outfile : String) -> Core (List String)

354 | compileToSCM c tm outfile

355 |     = do cdata <- getCompileData False Cases tm

356 |          let ndefs = namedDefs cdata

357 |          -- let tags = nameTags cdata

358 |          let ctm = forget (mainExpr cdata)

360 |          ds <- getDirectives Gambit

361 |          let schLazy = if getWeakMemoLazy ds then weakMemoLaziness else defaultLaziness

363 |          defs <- get Ctxt

364 |          l <- newRef {t = List String} Loaded []

365 |          s <- newRef {t = List String} Structs []

366 |          fgndefs <- traverse getFgnCall ndefs

367 |          (sortedDefs, constants) <- sortDefs ndefs

368 |          compdefs <- traverse (getScheme constants (gambitPrim constants schLazy) gambitString schLazy) ndefs

369 |          let code = concat (map snd fgndefs) ++ concat compdefs

370 |          main <- schExp constants (gambitPrim constants schLazy) gambitString schLazy 0 ctm

371 |          support <- readDataFile "gambit/support.scm"

372 |          extraRuntime <- getExtraRuntime ds

373 |          foreign <- readDataFile "gambit/foreign.scm"

374 |          let scm = sepBy "\n" [schHeader, fromString support, fromString extraRuntime, fromString foreign, code, main]

375 |          Right () <- coreLift $ writeFile outfile $ build scm

376 |             | Left err => throw (FileErr outfile err)

377 |          pure $ mapMaybe fst fgndefs

379 | compileExpr :

380 |   Ref Ctxt Defs ->

381 |   Ref Syn SyntaxInfo ->

382 |   (tmpDir : String) -> (outputDir : String) ->

383 |   ClosedTerm -> (outfile : String) -> Core (Maybe String)

384 | compileExpr c s tmpDir outputDir tm outfile

385 |     = do let srcPath = tmpDir </> outfile <.> "scm"

386 |          let execPath = outputDir </> outfile

387 |          libsname <- compileToSCM c tm srcPath

388 |          libsfile <- traverse findLibraryFile $ map (<.> "a") (nub libsname)

389 |          gsc <- coreLift findGSC

390 |          gscBackend <- coreLift findGSCBackend

391 |          ds <- getDirectives Gambit

392 |          let gscCompileOpts =

393 |              case find (== "C") ds of

394 |                  Nothing => gscBackend ++ ["-exe", "-cc-options", "-Wno-implicit-function-declaration", "-ld-options"] ++ libsfile

395 |                  Just _ => ["-c"]

396 |          let cmd = gsc ++ gscCompileOpts ++ ["-o", execPath, srcPath]

397 |          ok <- coreLift $ system cmd

398 |          if ok == 0

399 |             then pure (Just execPath)

400 |             else pure Nothing

402 | executeExpr :

403 |   Ref Ctxt Defs ->

404 |   Ref Syn SyntaxInfo ->

405 |   (tmpDir : String) -> ClosedTerm -> Core ()

406 | executeExpr c s tmpDir tm

407 |     = do Just sh <- compileExpr c s tmpDir tmpDir tm "_tmpgambit"

408 |            | Nothing => throw (InternalError "compileExpr returned Nothing")

409 |          coreLift_ $ system [sh] -- TODO: on windows, should add exe extension

410 |          pure ()

413 | codegenGambit : Codegen

414 | codegenGambit = MkCG compileExpr executeExpr Nothing Nothing