0 | module Compiler.Scheme.Chez

  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

 15 | import Data.String

 17 | import Idris.Env

 18 | import Idris.Syntax

 20 | import System

 21 | import System.Directory

 22 | import System.Info

 24 | import Libraries.Data.Version

 25 | import Libraries.Utils.String

 27 | %default covering

 30 | findChez : IO String

 32 |     = do Nothing <- idrisGetEnv "CHEZ"

 33 |             | Just chez => pure chez

 34 |          path <- pathLookup ["chez", "chezscheme", "chez-scheme", "chezscheme9.5", "scheme"]

 35 |          pure $ fromMaybe "/usr/bin/env scheme" path

 43 | chezVersion : String -> IO (Maybe Version)

 44 | chezVersion chez = do

 45 |     Right fh <- popen cmd Read

 46 |         | Left err => pure Nothing

 47 |     Right output <- fGetLine fh

 48 |         | Left err => pure Nothing

 49 |     ignore $ pclose fh

 50 |     pure $ parseVersion output

 51 |   where

 52 |   cmd : String

 53 |   cmd = chez ++ " --version 2>&1"

 55 | unsupportedCallingConvention : Maybe Version -> Bool

 56 | unsupportedCallingConvention Nothing = True

 57 | unsupportedCallingConvention (Just version) = version < MkVersion (9,5,0) Nothing

 66 | findLibs : {auto c : Ref Ctxt Defs} ->

 67 |            List String -> Core (List (String, String))

 68 | findLibs ds

 69 |     = do let libs = mapMaybe (isLib . trim) ds

 70 |          traverse locate (nub libs)

 71 |   where

 72 |     isLib : String -> Maybe String

 73 |     isLib d

 74 |         = if isPrefixOf "lib" d

 75 |              then Just (trim (substr 3 (length d) d))

 76 |              else Nothing

 78 | schHeader : String -> List String -> Bool -> Builder

 79 | schHeader chez libs whole

 80 |   = fromString $

 81 |     (if os /= "windows"

 82 |         then "#!" ++ chez ++ (if whole then " --program\n\n" else " --script\n\n")

 83 |         else "") ++ """

104 | schFooter : Bool -> Bool -> Builder

105 | schFooter prof whole = fromString """

113 | showChezChar : Char -> Builder -> Builder

114 | showChezChar '\\' acc = "\\\\" ++ acc

115 | showChezChar c acc

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

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

118 |         else char c ++ acc

120 | showChezString : List Char -> Builder -> Builder

121 | showChezString [] acc = acc

122 | showChezString ('"' :: cs) acc = "\\\"" ++ showChezString cs acc

123 | showChezString (c :: cs) acc = showChezChar c $ showChezString cs acc

126 | chezString : String -> Builder

127 | chezString cs = "\"" ++ showChezString (unpack cs) "\""

129 | handleRet : CFType -> Builder -> Builder

130 | handleRet CFUnit op = op ++ " " ++ mkWorld (schConstructor chezString (UN Underscore) (Just 0) [])

131 | handleRet _ op = mkWorld op

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

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

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

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

139 | chezExtPrim : SortedSet Name -> LazyExprProc -> Nat -> ExtPrim -> List NamedCExp -> Core Builder

140 | chezExtPrim cs schLazy i GetField [NmPrimVal _ (Str s), _, _, struct,

141 |                                    NmPrimVal _ (Str fld), _]

142 |     = do structsc <- schExp cs (chezExtPrim cs schLazy) chezString schLazy 0 struct

143 |          pure $ "(ftype-ref " ++ fromString s ++ " (" ++ fromString fld ++ ") " ++ structsc ++ ")"

144 | chezExtPrim cs schLazy i GetField [_,_,_,_,_,_]

145 |     = pure "(blodwen-error-quit \"bad getField\")"

146 | chezExtPrim cs schLazy i SetField [NmPrimVal _ (Str s), _, _, struct,

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

148 |     = do structsc <- schExp cs (chezExtPrim cs schLazy) chezString schLazy 0 struct

149 |          valsc <- schExp cs (chezExtPrim cs schLazy) chezString schLazy 0 val

150 |          pure $ mkWorld $

151 |             "(ftype-set! " ++ fromString s ++ " (" ++ fromString fld ++ ") " ++ structsc ++

152 |             " " ++ valsc ++ ")"

153 | chezExtPrim cs schLazy i SetField [_,_,_,_,_,_,_,_]

154 |     = pure "(blodwen-error-quit \"bad setField\")"

155 | chezExtPrim cs schLazy i SysCodegen []

156 |     = pure $ "\"chez\""

157 | chezExtPrim cs schLazy i OnCollect [_, p, c, world]

158 |     = do p' <- schExp cs (chezExtPrim cs schLazy) chezString schLazy 0 p

159 |          c' <- schExp cs (chezExtPrim cs schLazy) chezString schLazy 0 c

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

161 | chezExtPrim cs schLazy i OnCollectAny [p, c, world]

162 |     = do p' <- schExp cs (chezExtPrim cs schLazy) chezString schLazy 0 p

163 |          c' <- schExp cs (chezExtPrim cs schLazy) chezString schLazy 0 c

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

165 | chezExtPrim cs schLazy i prim args

166 |     = schExtCommon cs (chezExtPrim cs schLazy) chezString schLazy i prim args

170 | data Loaded : Type where

174 | data Structs : Type where

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

177 | cftySpec fc CFUnit = pure "void"

178 | cftySpec fc CFInt = pure "int"

179 | cftySpec fc CFInt8 = pure "integer-8"

180 | cftySpec fc CFInt16 = pure "integer-16"

181 | cftySpec fc CFInt32 = pure "integer-32"

182 | cftySpec fc CFInt64 = pure "integer-64"

183 | cftySpec fc CFUnsigned8 = pure "unsigned-8"

184 | cftySpec fc CFUnsigned16 = pure "unsigned-16"

185 | cftySpec fc CFUnsigned32 = pure "unsigned-32"

186 | cftySpec fc CFUnsigned64 = pure "unsigned-64"

187 | cftySpec fc CFString = pure "string"

188 | cftySpec fc CFDouble = pure "double"

189 | cftySpec fc CFChar = pure "char"

190 | cftySpec fc CFPtr = pure "void*"

191 | cftySpec fc CFGCPtr = pure "void*"

192 | cftySpec fc CFBuffer = pure "u8*"

193 | cftySpec fc (CFFun s t) = pure "void*"

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

195 | cftySpec fc (CFStruct n t) = pure $ "(* " ++ fromString n ++ ")"

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

197 |                          " to foreign function"))

199 | locateLib : {auto c : Ref Ctxt Defs} -> String -> String -> Core String

200 | locateLib appdir clib

201 |     = do (fname, fullname) <- locate clib

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

203 |          pure fname

206 | loadLib : {auto c : Ref Ctxt Defs} ->

207 |           String -> String -> Core String

208 | loadLib appdir clib

209 |     = do fname <- locateLib appdir clib

210 |          pure $ "(load-shared-object \""

211 |                                     ++ escapeStringChez fname

212 |                                     ++ "\")\n"

214 | loadSO : {auto c : Ref Ctxt Defs} ->

215 |          String -> String -> Core String

216 | loadSO appdir "" = pure ""

217 | loadSO appdir mod

218 |     = do d <- getDirs

219 |          bdir <- ttcBuildDirectory

220 |          allDirs <- extraSearchDirectories

221 |          let fs = map (\p => p </> mod) (bdir :: allDirs)

222 |          Just fname <- firstAvailable fs

223 |             | Nothing => throw (InternalError ("Missing .so:" ++ mod))

224 |          -- Easier to put them all in the same directory, so we don't need

225 |          -- to traverse a directory tree when installing the executable. So,

226 |          -- separate with '-' rather than directory separators.

227 |          let modfname = fastConcat (intersperse "-" (splitPath mod))

228 |          copyLib (appdir </> modfname, fname)

229 |          pure $ "(load \"" ++ escapeStringChez modfname ++ "\")\n"

231 | cCall : {auto c : Ref Ctxt Defs}

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

233 |      -> FC

234 |      -> (cfn : String)

235 |      -> (clib : String)

236 |      -> List (Name, CFType)

237 |      -> CFType

238 |      -> (collectSafe : Bool)

239 |      -> Core (Maybe String, Builder)

240 | cCall fc cfn clib args (CFIORes CFGCPtr) _

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

242 | cCall fc cfn clib args CFGCPtr _

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

244 | cCall fc cfn clib args (CFIORes CFBuffer) _

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

246 | cCall fc cfn clib args CFBuffer _

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

248 | cCall fc cfn clib args ret collectSafe

249 |     = do loaded <- get Loaded

250 |          lib <- if clib `elem` loaded

251 |                    then pure Nothing

252 |                    else do put Loaded (clib :: loaded)

253 |                            pure (Just clib)

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

255 |          retType <- cftySpec fc ret

256 |          let callConv : Builder = if collectSafe then " __collect_safe" else ""

257 |          let call = "((foreign-procedure" ++ callConv ++ " " ++ showB cfn ++ " ("

258 |                       ++ sepBy " " argTypes ++ ") " ++ retType ++ ") "

259 |                       ++ sepBy " " !(traverse buildArg args) ++ ")"

261 |          pure (lib, case ret of

262 |                          CFIORes _ => handleRet ret call

263 |                          _ => call)

264 |   where

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

266 |     mkNs i [] = []

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

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

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

271 |     applyLams n [] = n

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

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

275 |     getVal : Builder -> Builder

276 |     getVal str = "(vector-ref " ++ str ++ "1)"

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

279 |     mkFun args ret n

280 |         = let argns = mkNs 0 args in

281 |               "(lambda (" ++ sepBy " " (catMaybes argns) ++ ") " ++

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

284 |     notWorld : CFType -> Bool

285 |     notWorld CFWorld = False

286 |     notWorld _ = True

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

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

290 |     callback n args_rev retty

291 |         = do let args = reverse args_rev

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

293 |              retType <- cftySpec fc retty

294 |              pure $

295 |                  "(let ([c-code (foreign-callable #f " ++

296 |                        mkFun args retty n ++

297 |                        " (" ++ sepBy " " argTypes ++ ") " ++ retType ++ ")])" ++

298 |                        " (lock-object c-code) (foreign-callable-entry-point c-code))"

300 |     buildArg : (Name, CFType) -> Core Builder

301 |     buildArg (n, CFFun s t) = callback (schName n) [s] t

302 |     buildArg (n, CFGCPtr) = pure $ "(car " ++ schName n ++ ")"

303 |     buildArg (n, _) = pure $ schName n

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

306 |              List Name -> CFType -> Core Builder

307 | schemeCall fc sfn argns ret

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

309 |           case ret of

310 |                CFIORes _ => pure $ mkWorld call

311 |                _ => pure call

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

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

318 |         FC -> List String -> List (Name, CFType) -> CFType ->

319 |         Maybe Version -> Core (Maybe String, Builder)

320 | useCC fc ccs args ret version

321 |     = case parseCC ["scheme,chez", "scheme", "C__collect_safe", "C"] ccs of

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

323 |                do body <- schemeCall fc sfn (map fst args) ret

324 |                   pure (Nothing, body)

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

326 |                do body <- schemeCall fc sfn (map fst args) ret

327 |                   pure (Nothing, body)

328 |            Just ("C__collect_safe", (cfn :: clib :: _)) => do

329 |              if unsupportedCallingConvention version

330 |                then cCall fc cfn clib args ret False

331 |                else cCall fc cfn clib args ret True

332 |            Just ("C", (cfn :: clib :: _)) =>

333 |              cCall fc cfn clib args ret False

334 |            _ => throw (NoForeignCC fc ccs)

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

339 | mkArgs i [] = []

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

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

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

344 |            CFType -> Core Builder

345 | mkStruct (CFStruct n flds)

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

347 |          strs <- get Structs

348 |          if n `elem` strs

349 |             then pure (concat defs)

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

351 |                     pure $ concat defs ++ "(define-ftype " ++ fromString n ++ " (struct\n\t"

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

353 |   where

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

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

356 | mkStruct (CFIORes t) = mkStruct t

357 | mkStruct (CFFun a b) = do [| mkStruct a ++ mkStruct b |]

358 | mkStruct _ = pure ""

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

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

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

363 |             FC -> Name -> NamedDef -> Maybe Version ->

364 |             Core (Maybe String, Builder)

365 | schFgnDef fc n (MkNmForeign cs args ret) version

366 |     = do let argns = mkArgs 0 args

367 |          let allargns = map fst argns

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

369 |          argStrs <- traverse mkStruct args

370 |          retStr <- mkStruct ret

371 |          (load, body) <- useCC fc cs (zip useargns args) ret version

372 |          defs <- get Ctxt

373 |          pure (load,

374 |                 concat argStrs ++ retStr ++

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

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

377 |                 body ++ "))\n")

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

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

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

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

384 |              Maybe Version -> (Name, FC, NamedDef) ->

385 |              Core (Maybe String, Builder)

386 | getFgnCall version (n, fc, d) = schFgnDef fc n d version

389 | startChezPreamble : String

390 | startChezPreamble = """

404 | startChez : String -> String -> String

405 | startChez appdir target = startChezPreamble ++ """

413 | startChezCmd : String -> String -> String -> String -> String

414 | startChezCmd chez appdir target progType = """

426 | startChezWinSh : String -> String -> String -> String -> String

427 | startChezWinSh chez appdir target progType = """

444 | collectRequestHandler : Builder

445 | collectRequestHandler = """

478 | compileToSS : Ref Ctxt Defs ->

479 |               Bool -> -- profiling

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

481 | compileToSS c prof appdir tm outfile

482 |     = do ds <- getDirectives Chez

483 |          libs <- findLibs ds

484 |          traverse_ copyLib libs

485 |          cdata <- getCompileData False Cases tm

486 |          let ndefs = namedDefs cdata

487 |          let ctm = forget (mainExpr cdata)

489 |          defs <- get Ctxt

490 |          l <- newRef {t = List String} Loaded ["libc", "libc 6"]

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

492 |          chez <- coreLift findChez

493 |          version <- coreLift $ chezVersion chez

494 |          fgndefs <- traverse (getFgnCall version) ndefs

495 |          loadlibs <- traverse (locateLib appdir) (mapMaybe fst fgndefs)

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

499 |          (sortedDefs, constants) <- sortDefs ndefs

500 |          compdefs <- logTime 3 "Print as scheme" $ traverse (getScheme constants (chezExtPrim constants schLazy) chezString schLazy) sortedDefs

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

502 |          main <- schExp constants (chezExtPrim constants schLazy) chezString schLazy 0 ctm

503 |          support <- readDataFile "chez/support.ss"

504 |          extraRuntime <- getExtraRuntime ds

505 |          let scm = concat $ the (List _)

506 |                    [ schHeader chez (map snd libs ++ loadlibs) True

507 |                    , fromString support

508 |                    , fromString extraRuntime

509 |                    , code

510 |                    , collectRequestHandler ++ "\n"

511 |                    , main

512 |                    , schFooter prof True

513 |                    ]

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

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

516 |          coreLift_ $ chmodRaw outfile 0o755

519 | compileToSO : {auto c : Ref Ctxt Defs} ->

520 |               Bool -> -- profiling

521 |               String -> (appDirRel : String) -> (outSsAbs : String) -> Core ()

522 | compileToSO prof chez appDirRel outSsAbs

523 |     = do let tmpFileAbs = appDirRel </> "compileChez"

524 |          let build = "(parameterize ([optimize-level 3] "

525 |                      ++ (if prof then "[compile-profile #t] "

526 |                                 else "") ++

527 |                      "[compile-file-message #f]) (compile-program " ++

528 |                     show outSsAbs ++ "))"

529 |          Right () <- coreLift $ writeFile tmpFileAbs build

530 |             | Left err => throw (FileErr tmpFileAbs err)

531 |          coreLift_ $ chmodRaw tmpFileAbs 0o755

532 |          0 <- coreLift $ system [chez, "--script", tmpFileAbs]

533 |             | status => throw (InternalError "Chez exited with return code \{show status}")

534 |          pure ()

537 | compileToSSInc : Ref Ctxt Defs ->

538 |                  List String -> -- module so files

539 |                  List String -> -- libraries to find and load

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

541 | compileToSSInc c mods libs appdir tm outfile

542 |     = do chez <- coreLift findChez

543 |          tmcexp <- compileTerm tm

544 |          let ctm = forget tmcexp

546 |          loadlibs <- traverse (map fromString . loadLib appdir) (nub libs)

547 |          loadsos <- traverse (map fromString . loadSO appdir) (nub mods)

549 |          main <- schExp empty (chezExtPrim empty defaultLaziness) chezString defaultLaziness 0 ctm

550 |          support <- readDataFile "chez/support.ss"

552 |          let scm = schHeader chez [] False ++

553 |                    fromString support ++

554 |                    concat loadlibs ++

555 |                    concat loadsos ++

556 |                    collectRequestHandler ++ "\n" ++

557 |                    main ++ schFooter False False

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

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

561 |          coreLift_ $ chmodRaw outfile 0o755

562 |          pure ()

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

566 | makeSh outShRel appdir outAbs

567 |     = do Right () <- coreLift $ writeFile outShRel (startChez appdir outAbs)

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

569 |          pure ()

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

573 | makeShWindows chez outShRel appdir outAbs progType

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

575 |          Right () <- coreLift $ writeFile cmdFile (startChezCmd chez appdir outAbs progType)

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

577 |          Right () <- coreLift $ writeFile outShRel (startChezWinSh chez appdir outAbs progType)

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

579 |          pure ()

581 | compileExprWhole :

582 |   Bool ->

583 |   Ref Ctxt Defs ->

584 |   Ref Syn SyntaxInfo ->

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

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

587 | compileExprWhole makeitso c s tmpDir outputDir tm outfile

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

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

590 |          coreLift_ $ mkdirAll appDirGen

591 |          Just cwd <- coreLift currentDir

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

593 |          let outSsFile = appDirRel </> outfile <.> "ss"

594 |          let outSoFile = appDirRel </> outfile <.> "so"

595 |          let outSsAbs = cwd </> outputDir </> outSsFile

596 |          let outSoAbs = cwd </> outputDir </> outSoFile

597 |          chez <- coreLift $ findChez

598 |          let prof = profile !getSession

599 |          logTime 2 "Compile to scheme" $ compileToSS c (makeitso && prof) appDirGen tm outSsAbs

600 |          logTime 2 "Make SO" $ when makeitso $

601 |            compileToSO prof chez appDirGen outSsAbs

602 |          let outShRel = outputDir </> outfile

603 |          if isWindows

604 |             then makeShWindows chez outShRel appDirRel (if makeitso then outSoFile else outSsFile) "--program"

605 |             else makeSh outShRel appDirRel (if makeitso then outSoFile else outSsFile)

606 |          coreLift_ $ chmodRaw outShRel 0o755

607 |          pure (Just outShRel)

609 | compileExprInc :

610 |   Bool ->

611 |   Ref Ctxt Defs ->

612 |   Ref Syn SyntaxInfo ->

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

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

615 | compileExprInc makeitso c s tmpDir outputDir tm outfile

616 |     = do defs <- get Ctxt

617 |          let Just (mods, libs) = lookup Chez (allIncData defs)

618 |              | Nothing =>

619 |                  do coreLift $ putStrLn $ "Missing incremental compile data, reverting to whole program compilation"

620 |                     compileExprWhole makeitso c s tmpDir outputDir tm outfile

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

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

623 |          coreLift_ $ mkdirAll appDirGen

624 |          Just cwd <- coreLift currentDir

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

626 |          let outSsFile = appDirRel </> outfile <.> "ss"

627 |          let outSoFile = appDirRel </> outfile <.> "so"

628 |          let outSsAbs = cwd </> outputDir </> outSsFile

629 |          let outSoAbs = cwd </> outputDir </> outSoFile

630 |          chez <- coreLift $ findChez

631 |          compileToSSInc c mods libs appDirGen tm outSsAbs

632 |          let outShRel = outputDir </> outfile

633 |          if isWindows

634 |             then makeShWindows chez outShRel appDirRel outSsFile "--script"

635 |             else makeSh outShRel appDirRel outSsFile

636 |          coreLift_ $ chmodRaw outShRel 0o755

637 |          pure (Just outShRel)

640 | compileExpr :

641 |   Bool ->

642 |   Ref Ctxt Defs ->

643 |   Ref Syn SyntaxInfo ->

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

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

646 | compileExpr makeitso c s tmpDir outputDir tm outfile

647 |     = do sesh <- getSession

648 |          if not (wholeProgram sesh) && (Chez `elem` incrementalCGs sesh)

649 |             then compileExprInc makeitso c s tmpDir outputDir tm outfile

650 |             else compileExprWhole makeitso c s tmpDir outputDir tm outfile

654 | executeExpr :

655 |   Ref Ctxt Defs ->

656 |   Ref Syn SyntaxInfo ->

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

658 | executeExpr c s tmpDir tm

659 |     = do Just sh <- compileExpr False c s tmpDir tmpDir tm "_tmpchez"

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

661 |          coreLift_ $ system [sh]

663 | incCompile :

664 |   Ref Ctxt Defs ->

665 |   Ref Syn SyntaxInfo ->

666 |   (sourceFile : String) -> Core (Maybe (String, List String))

667 | incCompile c s sourceFile

668 |     = do

669 |          ssFile <- getTTCFileName sourceFile "ss"

670 |          soFile <- getTTCFileName sourceFile "so"

671 |          soFilename <- getObjFileName sourceFile "so"

672 |          cdata <- getIncCompileData False Cases

674 |          d <- getDirs

675 |          outputDir <- ttcBuildDirectory

677 |          let ndefs = namedDefs cdata

678 |          if isNil ndefs

679 |             then pure (Just ("", []))

680 |                       -- ^ no code to generate, but still recored that the

681 |                       -- module has been compiled, with no output needed.

682 |             else do

683 |                l <- newRef {t = List String} Loaded ["libc", "libc 6"]

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

685 |                chez <- coreLift findChez

686 |                version <- coreLift $ chezVersion chez

687 |                fgndefs <- traverse (getFgnCall version) ndefs

688 |                (sortedDefs, constants) <- sortDefs ndefs

689 |                compdefs <- traverse (getScheme empty (chezExtPrim empty defaultLaziness) chezString defaultLaziness) sortedDefs

690 |                let code = concat $ map snd fgndefs ++ compdefs

691 |                Right () <- coreLift $ writeFile ssFile $ build code

692 |                   | Left err => throw (FileErr ssFile err)

694 |                -- Compile to .so

695 |                let tmpFileAbs = outputDir </> "compileChez"

696 |                let build = "(parameterize ([optimize-level 3] " ++

697 |                            "[compile-file-message #f]) (compile-file " ++

698 |                           show ssFile ++ "))"

699 |                Right () <- coreLift $ writeFile tmpFileAbs build

700 |                   | Left err => throw (FileErr tmpFileAbs err)

701 |                0 <- coreLift $ system [chez, "--script", tmpFileAbs]

702 |                   | status => throw (InternalError "Chez exited with return code \{show status}")

703 |                pure (Just (soFilename, mapMaybe fst fgndefs))

707 | codegenChez : Codegen

708 | codegenChez = MkCG (compileExpr True) executeExpr (Just incCompile) (Just "so")