0 | module Compiler.Scheme.Racket

  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.Data.String.Builder

 11 | import Libraries.Utils.Path

 13 | import Data.Maybe

 14 | import Data.String

 15 | import Data.SortedSet

 17 | import Idris.Env

 18 | import Idris.Syntax

 20 | import System

 21 | import System.Directory

 22 | import System.Info

 24 | %default covering

 26 | findRacket : IO String

 27 | findRacket =

 28 |   do env <- idrisGetEnv "RACKET"

 29 |      pure $ fromMaybe "/usr/bin/env racket" env

 31 | findRacoExe : IO (List String)

 32 | findRacoExe =

 33 |   do env <- idrisGetEnv "RACKET_RACO"

 34 |      pure $ (maybe ["/usr/bin/env", "raco"] singleton env) ++ ["exe"]

 36 | schHeader : Bool -> Builder -> Builder

 37 | schHeader prof libs = fromString """

 54 |   """ ++ libs ++ """

 60 | schFooter : Builder

 61 | schFooter = """

 66 | showRacketChar : Char -> Builder -> Builder

 67 | showRacketChar '\\' acc = "\\\\" ++ acc

 68 | showRacketChar c acc

 69 |    = if ord c < 32 || ord c > 126

 70 |         then fromString ("\\u" ++ leftPad '0' 4 (asHex (cast c))) ++ acc

 71 |         else char c ++ acc

 73 | showRacketString : List Char -> Builder -> Builder

 74 | showRacketString [] acc = acc

 75 | showRacketString ('"' :: cs) acc = "\\\"" ++ showRacketString cs acc

 76 | showRacketString (c :: cs) acc = showRacketChar c $ showRacketString cs acc

 78 | racketString : String -> Builder

 79 | racketString cs = "\"" ++ showRacketString (unpack cs) "\""

 81 | racketPrim : SortedSet Name -> LazyExprProc -> Nat -> ExtPrim -> List NamedCExp -> Core Builder

 82 | racketPrim cs schLazy i GetField [NmPrimVal _ (Str s), _, _, struct,

 83 |                        NmPrimVal _ (Str fld), _]

 84 |     = do structsc <- schExp cs (racketPrim cs schLazy) racketString schLazy 0 struct

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

 86 | racketPrim cs schLazy i GetField [_,_,_,_,_,_]

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

 88 | racketPrim cs schLazy i SetField [NmPrimVal _ (Str s), _, _, struct,

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

 90 |     = do structsc <- schExp cs (racketPrim cs schLazy) racketString schLazy 0 struct

 91 |          valsc <- schExp cs (racketPrim cs schLazy) racketString schLazy 0 val

 92 |          pure $ mkWorld $

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

 94 | racketPrim cs schLazy i SetField [_,_,_,_,_,_,_,_]

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

 96 | racketPrim cs schLazy i SysCodegen []

 97 |     = pure $ "\"racket\""

 98 | racketPrim cs schLazy i OnCollect [_, p, c, world]

 99 |     = do p' <- schExp cs (racketPrim cs schLazy) racketString schLazy 0 p

100 |          c' <- schExp cs (racketPrim cs schLazy) racketString schLazy 0 c

101 |          pure $ mkWorld $ "(blodwen-register-object " ++ p' ++ " " ++ c' ++ ")"

102 | racketPrim cs schLazy i OnCollectAny [p, c, world]

103 |     = do p' <- schExp cs (racketPrim cs schLazy) racketString schLazy 0 p

104 |          c' <- schExp cs (racketPrim cs schLazy) racketString schLazy 0 c

105 |          pure $ mkWorld $ "(blodwen-register-object " ++ p' ++ " " ++ c' ++ ")"

106 | racketPrim cs schLazy i prim args

107 |     = schExtCommon cs (racketPrim cs schLazy) racketString schLazy i prim args

110 | data Loaded : Type where

113 | data Structs : Type where

116 | data Done : Type where

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

119 | cftySpec fc CFUnit = pure "_void"

120 | cftySpec fc CFInt = pure "_int"

121 | cftySpec fc CFInt8 = pure "_int8"

122 | cftySpec fc CFInt16 = pure "_int16"

123 | cftySpec fc CFInt32 = pure "_int32"

124 | cftySpec fc CFInt64 = pure "_int64"

125 | cftySpec fc CFUnsigned8 = pure "_uint8"

126 | cftySpec fc CFUnsigned16 = pure "_uint16"

127 | cftySpec fc CFUnsigned32 = pure "_uint32"

128 | cftySpec fc CFUnsigned64 = pure "_uint64"

129 | cftySpec fc CFString = pure "_string/utf-8"

130 | cftySpec fc CFDouble = pure "_double"

131 | cftySpec fc CFChar = pure "_int8"

132 | cftySpec fc CFPtr = pure "_pointer"

133 | cftySpec fc CFGCPtr = pure "_pointer"

134 | cftySpec fc CFBuffer = pure "_bytes"

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

136 | cftySpec fc (CFStruct n t) = pure $ "_" ++ fromString n ++ "-pointer"

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

138 |   where

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

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

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

142 |     funTySpec args retty

143 |         = do rtyspec <- cftySpec fc retty

144 |              argspecs <- traverse (cftySpec fc) (reverse args)

145 |              pure $ "(_fun " ++ sepBy " " argspecs ++ " -> " ++ rtyspec ++ ")"

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

147 |                          " to foreign function"))

149 | loadlib : String -> String -> String

150 | loadlib "libc" _ = "(define-ffi-definer define-libc (ffi-lib #f))\n"

151 | loadlib libn ver

152 |     = "(define-ffi-definer define-" ++ libn ++

153 |       " (ffi-lib \"" ++ libn ++ "\" " ++ ver ++ "))\n"

155 | getLibVers : String -> (String, String)

156 | getLibVers libspec

157 |     = case words libspec of

158 |            [] => ("", "")

159 |            [fn] => case span (/='.') libspec of

160 |                         (root, rest) => (root, "")

161 |            (fn :: vers) =>

162 |                (fst (span (/='.') fn),

163 |                   "'(" ++ showSep " " (map show vers) ++ " #f)" )

165 | cToRkt : CFType -> Builder -> Builder

166 | cToRkt CFChar op = "(integer->char " ++ op ++ ")"

167 | cToRkt _ op = op

169 | rktToC : CFType -> Builder -> Builder

170 | rktToC CFChar op = "(char->integer " ++ op ++ ")"

171 | rktToC _ op = op

173 | handleRet : CFType -> Builder -> Builder

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

175 | handleRet ret op = mkWorld (cToRkt ret op)

177 | cCall : {auto f : Ref Done (List String) } ->

178 |         {auto c : Ref Ctxt Defs} ->

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

180 |         String -> FC -> (cfn : String) -> (clib : String) ->

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

182 | cCall appdir fc cfn clib args (CFIORes CFGCPtr)

183 |     = throw (GenericMsg fc "Can't return GCPtr from a foreign function")

184 | cCall appdir fc cfn clib args CFGCPtr

185 |     = throw (GenericMsg fc "Can't return GCPtr from a foreign function")

186 | cCall appdir fc cfn clib args (CFIORes CFBuffer)

187 |     = throw (GenericMsg fc "Can't return Buffer from a foreign function")

188 | cCall appdir fc cfn clib args CFBuffer

189 |     = throw (GenericMsg fc "Can't return Buffer from a foreign function")

190 | cCall appdir fc cfn libspec args ret

191 |     = do loaded <- get Loaded

192 |          bound <- get Done

194 |          let (libn, vers) = getLibVers libspec

195 |          lib <- if libn `elem` loaded

196 |                    then pure ""

197 |                    else do put Loaded (libn :: loaded)

198 |                            (fname, fullname) <- locate libspec

199 |                            copyLib (appdir </> fname, fullname)

200 |                            pure (loadlib libn vers)

202 |          argTypes <- traverse (\a => do s <- cftySpec fc (snd a)

203 |                                         pure (a, s)) args

204 |          retType <- cftySpec fc ret

205 |          cbind <- if cfn `elem` bound

206 |                      then pure ""

207 |                      else do put Done (cfn :: bound)

208 |                              pure $ "(define-" ++ fromString libn ++ " " ++ fromString cfn ++

209 |                                     " (_fun " ++ sepBy " " (map snd argTypes) ++ " -> " ++

210 |                                         retType ++ "))\n"

211 |          let call = "(" ++ fromString cfn ++ " " ++

212 |                     sepBy " " !(traverse useArg (map fst argTypes)) ++ ")"

214 |          pure (fromString lib ++ cbind, case ret of

215 |                                   CFIORes rt => handleRet rt call

216 |                                   _ => call)

217 |   where

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

219 |     mkNs i [] = []

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

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

223 |     applyLams : Builder -> List (Maybe (Builder, CFType)) -> Builder

224 |     applyLams n [] = n

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

226 |     applyLams n (Just (a, ty) :: as)

227 |         = applyLams ("(" ++ n ++ " " ++ cToRkt ty a ++ ")") as

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

230 |     mkFun args ret n

231 |         = let argns = mkNs 0 args in

232 |               "(lambda (" ++ sepBy " " (map fst (catMaybes argns)) ++ ") " ++

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

235 |     notWorld : CFType -> Bool

236 |     notWorld CFWorld = False

237 |     notWorld _ = True

239 |     callback : Builder -> List CFType -> CFType -> Core Builder

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

241 |     callback n args_rev retty

242 |         = do let args = reverse args_rev

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

244 |              retType <- cftySpec fc retty

245 |              pure $ mkFun args retty n

247 |     useArg : (Name, CFType) -> Core Builder

248 |     useArg (n, CFFun s t) = callback (schName n) [s] t

249 |     useArg (n, ty)

250 |         = pure $ rktToC ty (schName n)

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

253 |              List Name -> CFType -> Builder

254 | schemeCall fc sfn argns ret

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

256 |           case ret of

257 |                CFIORes _ => mkWorld call

258 |                _ => call

263 | useCC : {auto f : Ref Done (List String) } ->

264 |         {auto c : Ref Ctxt Defs} ->

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

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

267 | useCC appdir fc ccs args ret

268 |     = case parseCC ["scheme,racket", "scheme", "C"] ccs of

269 |            Nothing => throw (NoForeignCC fc ccs)

270 |            Just ("scheme,racket", [sfn]) =>

271 |                do let body = schemeCall fc sfn (map fst args) ret

272 |                   pure ("", body)

273 |            Just ("scheme,racket", [sfn, racketlib]) =>

274 |                do let body = schemeCall fc sfn (map fst args) ret

275 |                   pure (fromString $ "(require " ++ racketlib ++ ")", body)

276 |            Just ("scheme", [sfn]) =>

277 |                do let body = schemeCall fc sfn (map fst args) ret

278 |                   pure ("", body)

279 |            Just ("C", [cfn, clib]) => cCall appdir fc cfn clib args ret

280 |            Just ("C", [cfn, clib, chdr]) => cCall appdir fc cfn clib args ret

281 |            _ => throw (NoForeignCC fc ccs)

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

286 | mkArgs i [] = []

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

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

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

291 |            CFType -> Core Builder

292 | mkStruct (CFStruct n flds)

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

294 |          strs <- get Structs

295 |          if n `elem` strs

296 |             then pure (concat defs)

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

298 |                     pure $ concat defs ++ "(define-cstruct _" ++ fromString n ++ " ("

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

300 |   where

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

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

303 | mkStruct (CFIORes t) = mkStruct t

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

305 | mkStruct _ = pure ""

307 | schFgnDef : {auto f : Ref Done (List String) } ->

308 |             {auto c : Ref Ctxt Defs} ->

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

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

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

312 | schFgnDef appdir fc n (MkNmForeign cs args ret)

313 |     = do let argns = mkArgs 0 args

314 |          let allargns = map fst argns

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

316 |          argStrs <- traverse mkStruct args

317 |          retStr <- mkStruct ret

318 |          (load, body) <- useCC appdir fc cs (zip useargns args) ret

319 |          defs <- get Ctxt

320 |          pure (concat argStrs ++ retStr ++ load,

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

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

323 |                 body ++ "))\n")

324 | schFgnDef _ _ _ _ = pure ("", "")

326 | getFgnCall : {auto f : Ref Done (List String) } ->

327 |              {auto c : Ref Ctxt Defs} ->

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

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

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

331 | getFgnCall appdir (n, fc, d) = schFgnDef appdir fc n d

333 | startRacket : String -> String -> String -> String

334 | startRacket racket appdir target = """

352 | startRacketCmd : String -> String -> String -> String

353 | startRacketCmd racket appdir target = """

364 | startRacketWinSh : String -> String -> String -> String

365 | startRacketWinSh racket appdir target = """

377 | compileToRKT : Ref Ctxt Defs ->

378 |                String -> ClosedTerm -> (outfile : String) -> Core ()

379 | compileToRKT c appdir tm outfile

380 |     = do cdata <- getCompileData False Cases tm

381 |          let ndefs = namedDefs cdata

382 |          let ctm = forget (mainExpr cdata)

384 |          ds <- getDirectives Racket

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

387 |          defs <- get Ctxt

388 |          f <- newRef {t = List String} Done empty

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

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

391 |          fgndefs <- traverse (getFgnCall appdir) ndefs

392 |          (sortedDefs, constants) <- sortDefs ndefs

393 |          compdefs <- traverse (getScheme constants (racketPrim constants schLazy) racketString schLazy) sortedDefs

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

395 |          main <- schExp constants (racketPrim constants schLazy) racketString schLazy 0 ctm

396 |          support <- readDataFile "racket/support.rkt"

397 |          extraRuntime <- getExtraRuntime ds

398 |          let prof = profile !getSession

399 |          let runmain

400 |                 = if prof

401 |                      then "(profile (void " ++ main ++ ") #:order 'self)\n"

402 |                      else "(void " ++ main ++ ")\n"

403 |          let scm = schHeader prof (concat (map fst fgndefs)) ++

404 |                    fromString support ++ fromString extraRuntime ++ code ++

405 |                    runmain ++ schFooter

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

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

408 |          coreLift_ $ chmodRaw outfile 0o755

409 |          pure ()

411 | makeSh : String -> String -> String -> String -> Core ()

412 | makeSh racket outShRel appdir outAbs

413 |     = do Right () <- coreLift $ writeFile outShRel (startRacket racket appdir outAbs)

414 |             | Left err => throw (FileErr outShRel err)

415 |          pure ()

418 | makeShWindows : String -> String -> String -> String -> Core ()

419 | makeShWindows racket outShRel appdir outAbs

420 |     = do let cmdFile = outShRel ++ ".cmd"

421 |          Right () <- coreLift $ writeFile cmdFile (startRacketCmd racket appdir outAbs)

422 |             | Left err => throw (FileErr cmdFile err)

423 |          Right () <- coreLift $ writeFile outShRel (startRacketWinSh racket appdir outAbs)

424 |             | Left err => throw (FileErr outShRel err)

425 |          pure ()

427 | compileExpr :

428 |   Bool ->

429 |   Ref Ctxt Defs ->

430 |   Ref Syn SyntaxInfo ->

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

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

433 | compileExpr mkexec c s tmpDir outputDir tm outfile

434 |     = do let appDirRel = outfile ++ "_app" -- relative to build dir

435 |          let appDirGen = outputDir </> appDirRel -- relative to here

436 |          coreLift_ $ mkdirAll appDirGen

437 |          Just cwd <- coreLift currentDir

438 |               | Nothing => throw (InternalError "Can't get current directory")

440 |          let ext = if isWindows then ".exe" else ""

441 |          let outRktFile = appDirRel </> outfile <.> "rkt"

442 |          let outBinFile = appDirRel </> outfile <.> ext

443 |          let outRktAbs = cwd </> outputDir </> outRktFile

444 |          let outBinAbs = cwd </> outputDir </> outBinFile

446 |          compileToRKT c appDirGen tm outRktAbs

447 |          raco <- coreLift findRacoExe

448 |          racket <- coreLift findRacket

450 |          ok <- the (Core Int) $ if mkexec

451 |                   then logTime 1 "Build racket" $

452 |                          coreLift $ system $ raco ++ ["-o", outBinAbs, outRktAbs]

453 |                   else pure 0

454 |          if ok == 0

455 |             then do -- TODO: add launcher script

456 |                     let outShRel = outputDir </> outfile

457 |                     if isWindows

458 |                        then if mkexec

459 |                                then makeShWindows "" outShRel appDirRel outBinFile

460 |                                else makeShWindows (racket ++ " ") outShRel appDirRel outRktFile

461 |                        else if mkexec

462 |                                then makeSh "" outShRel appDirRel outBinFile

463 |                                else makeSh (racket ++ " ") outShRel appDirRel outRktFile

464 |                     coreLift_ $ chmodRaw outShRel 0o755

465 |                     pure (Just outShRel)

466 |             else pure Nothing

468 | executeExpr :

469 |   Ref Ctxt Defs ->

470 |   Ref Syn SyntaxInfo ->

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

472 | executeExpr c s tmpDir tm

473 |     = do Just sh <- compileExpr False c s tmpDir tmpDir tm "_tmpracket"

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

475 |          coreLift_ $ system [sh]

478 | codegenRacket : Codegen

479 | codegenRacket = MkCG (compileExpr True) executeExpr Nothing Nothing