0 | module Compiler.Scheme.ChezSep
  1 |
  2 | import Compiler.Common
  3 | import Compiler.CompileExpr
  4 | import Compiler.Generated
  5 | import Compiler.Scheme.Common
  6 | import Compiler.Scheme.Chez
  7 | import Compiler.Separate
  8 |
  9 | import Core.Hash
 10 | import Core.Directory
 11 | import Libraries.Data.String.Builder
 12 | import Libraries.Utils.Path
 13 |
 14 | import Data.List1
 15 | import Data.String
 16 |
 17 | import Idris.Syntax
 18 |
 19 | import System
 20 | import System.Directory
 21 | import System.Info
 22 |
 23 | import Libraries.Data.Version
 24 | import Libraries.Utils.String
 25 |
 26 | %default covering
 27 |
 28 | schHeader : List String -> List String -> Builder
 29 | schHeader libs compilationUnits = fromString """
 30 |   (import (chezscheme) (support)
 31 |       \{ unwords ["(" ++ cu ++ ")" | cu <- compilationUnits] })
 32 |   (case (machine-type)
 33 |     [(i3le ti3le a6le ta6le tarm64le) (load-shared-object "libc.so.6")]
 34 |     [(i3osx ti3osx a6osx ta6osx tarm64osx tppc32osx tppc64osx) (load-shared-object "libc.dylib")]
 35 |     [(i3nt ti3nt a6nt ta6nt) (load-shared-object "msvcrt.dll")]
 36 |     [else (load-shared-object "libc.so")]
 37 |   \{ unlines ["  (load-shared-object \"" ++ escapeStringChez lib ++ "\")" | lib <- libs] })
 38 |
 39 |   """
 40 |
 41 | schFooter : Builder
 42 | schFooter = """
 43 |
 44 |   (collect-request-handler (lambda () (collect (collect-maximum-generation)) (blodwen-run-finalisers)))
 45 |   (collect-rendezvous)
 46 |   """
 47 |
 48 | startChez : String -> String -> String -> String
 49 | startChez chez appDirSh targetSh = Chez.startChezPreamble ++ """
 50 |   export LD_LIBRARY_PATH="$DIR/\{ appDirSh }:$LD_LIBRARY_PATH"
 51 |   export DYLD_LIBRARY_PATH="$DIR/\{ appDirSh }:$DYLD_LIBRARY_PATH"
 52 |
 53 |   "\{ chez }" -q \
 54 |     --libdirs "$DIR/\{ appDirSh }" \
 55 |     --program "$DIR/\{ targetSh }" \
 56 |     "$@"
 57 |   """
 58 |
 59 | startChezCmd : String -> String -> String -> String
 60 | startChezCmd chez appDirSh targetSh = """
 61 |   @echo off
 62 |
 63 |   rem \{ generatedString "ChezSep" }
 64 |
 65 |   set APPDIR=%~dp0
 66 |   set PATH=%APPDIR%\{ appDirSh };%PATH%
 67 |
 68 |   "\{ chez }" -q \
 69 |     --libdirs "%APPDIR%\{ appDirSh }" \
 70 |     --program "%APPDIR%\{ targetSh }" \
 71 |     %*
 72 |   """
 73 |
 74 | startChezWinSh : String -> String -> String -> String
 75 | startChezWinSh chez appDirSh targetSh = """
 76 |   #!/bin/sh
 77 |   # \{ generatedString "ChezSep" }
 78 |
 79 |   set -e # exit on any error
 80 |
 81 |   DIR=$(dirname "$(readlink -f -- "$0" || cygpath -a -- "$0")")
 82 |   PATH="$DIR/\{ appDirSh }:$PATH"
 83 |
 84 |   "\{ chez }" --program "$DIR/\{ targetSh }" "$@"
 85 |   "\{ chez }" -q \
 86 |     --libdirs "$DIR/\{ appDirSh }" \
 87 |     --program "$DIR/\{ targetSh }" \
 88 |     "$@"
 89 |   """
 90 |
 91 | -- TODO: parallelise this
 92 | compileChezLibraries : (chez : String) -> (libDir : String) -> (ssFiles : List String) -> Core ()
 93 | compileChezLibraries chez libDir ssFiles = coreLift_ $ system
 94 |   [ "echo"
 95 |   , unwords
 96 |     [ "'(parameterize ([optimize-level 3] [compile-file-message #f]) (compile-library " ++ build (chezString ssFile) ++ "))'"
 97 |       ++ " '(delete-file " ++ build (chezString ssFile) ++ ")'"
 98 |       -- we must delete the SS file to prevent it from interfering with the SO files
 99 |       -- we keep the .hash file, though, so we still keep track of what to rebuild
100 |     | ssFile <- ssFiles
101 |     ]
102 |   , "|", chez, "-q", "--libdirs", libDir
103 |   ]
104 |
105 | compileChezLibrary : (chez : String) -> (libDir : String) -> (ssFile : String) -> Core ()
106 | compileChezLibrary chez libDir ssFile = coreLift_ $ system
107 |   [ "echo"
108 |   , "'(parameterize ([optimize-level 3] [compile-file-message #f]) (compile-library " ++ build (chezString ssFile) ++ "))'"
109 |   , "'(delete-file " ++ build (chezString ssFile) ++ ")'"
110 |   , "|", chez, "-q", "--libdirs", libDir
111 |   ]
112 |
113 | compileChezProgram : (chez : String) -> (libDir : String) -> (ssFile : String) -> Core ()
114 | compileChezProgram chez libDir ssFile = coreLift_ $ system
115 |   [ "echo"
116 |   , "'(parameterize ([optimize-level 3] [compile-file-message #f]) (compile-program " ++ build (chezString ssFile) ++ "))'"
117 |   , "'(delete-file " ++ build (chezString ssFile) ++ ")'"
118 |   , "|", chez, "-q", "--libdirs", libDir
119 |   ]
120 |
121 | chezNS : Namespace -> String
122 | chezNS ns = case showNSWithSep "-" ns of
123 |   "" => "unqualified"
124 |   nss => nss
125 |
126 | -- arbitrarily name the compilation unit
127 | -- after the alphabetically first namespace contained within
128 | chezLibraryName : CompilationUnit def -> String
129 | chezLibraryName cu = chezNS (foldl1 min cu.namespaces)
130 |
131 | touch : String -> Core ()
132 | touch s = coreLift_ $ system ["touch", s]
133 |
134 | record ChezLib where
135 |   constructor MkChezLib
136 |   name : String
137 |   isOutdated : Bool  -- needs recompiling
138 |
139 | ||| Compile a TT expression to a bunch of Chez Scheme files
140 | compileToSS : Ref Ctxt Defs -> String -> String -> ClosedTerm -> Core (Bool, List ChezLib)
141 | compileToSS c chez appdir tm = do
142 |   -- process native libraries
143 |   ds <- getDirectives Chez
144 |   libs <- findLibs ds
145 |   traverse_ copyLib libs
146 |   version <- coreLift $ chezVersion chez
147 |
148 |   -- get the material for compilation
149 |   cdata <- getCompileData False Cases tm
150 |   let ctm = forget (mainExpr cdata)
151 |   let ndefs = namedDefs cdata
152 |   let cui = getCompilationUnits ndefs
153 |
154 |   -- copy the support library
155 |   support <- readDataFile "chez/support-sep.ss"
156 |   let supportHash = show $ hash support
157 |   supportChanged <-
158 |     coreLift (readFile (appdir </> "support.hash")) >>= \case
159 |       Left err => pure True
160 |       Right fileHash => pure (fileHash /= supportHash)
161 |   when supportChanged $ do
162 |     Core.writeFile (appdir </> "support.ss") support
163 |     Core.writeFile (appdir </> "support.hash") supportHash
164 |
165 |   -- TODO: add extraRuntime
166 |   -- the problem with this is that it's unclear what to put in the (export) clause of the library
167 |   -- extraRuntime <- getExtraRuntime ds
168 |
169 |   -- for each compilation unit, generate code
170 |   chezLibs <- for cui.compilationUnits $ \cu => do
171 |     let chezLib = chezLibraryName cu
172 |
173 |     -- check if the hash has changed
174 |     -- TODO: also check that the .so file exists
175 |     let cuHash = show (hash cu)
176 |     hashChanged <-
177 |       coreLift (readFile (appdir </> chezLib <.> "hash")) >>= \case
178 |         Left err       => pure True
179 |         Right fileHash => pure (fileHash /= cuHash)
180 |
181 |     -- generate code only when necessary
182 |     when hashChanged $ do
183 |       defs <- get Ctxt
184 |       l <- newRef {t = List String} Loaded ["libc", "libc 6"]
185 |       s <- newRef {t = List String} Structs []
186 |
187 |       -- create imports + exports + header + footer
188 |       let imports = unwords
189 |             [ "(" ++
190 |                 maybe
191 |                   "unqualified"
192 |                   chezLibraryName
193 |                   (SortedMap.lookup cuid cui.byId)
194 |               ++ ")"
195 |             | cuid <- Prelude.toList cu.dependencies
196 |             ]
197 |       let exports = sepBy " " $ catMaybes
198 |             -- constructors don't generate Scheme definitions
199 |             [ case d of
200 |                 MkNmCon {} => Nothing
201 |                 _ => Just $ schName dn
202 |             | (dn, fc, d) <- cu.definitions
203 |             ]
204 |       let header =
205 |             "(library (" ++ fromString chezLib ++ ")\n"
206 |             ++ "  (export " ++ exports ++ ")\n"
207 |             ++ "  (import (chezscheme) (support) " ++ fromString imports ++ ")\n\n"
208 |       let footer = ")"
209 |
210 |       fgndefs <- traverse (Chez.getFgnCall version) cu.definitions
211 |       compdefs <- traverse (getScheme empty (Chez.chezExtPrim empty defaultLaziness) Chez.chezString defaultLaziness) cu.definitions
212 |       loadlibs <- traverse (map fromString . loadLib appdir) (mapMaybe fst fgndefs)
213 |
214 |       -- write the files
215 |       log "compiler.scheme.chez" 3 $ "Generating code for " ++ chezLib
216 |       Core.writeFile (appdir </> chezLib <.> "ss") $ build $ concat $
217 |         [header]
218 |         ++ map snd fgndefs  -- definitions using foreign libs
219 |         ++ compdefs
220 |         ++ loadlibs  -- foreign library load statements
221 |         ++ [footer]
222 |
223 |       Core.writeFile (appdir </> chezLib <.> "hash") cuHash
224 |
225 |     pure (MkChezLib chezLib hashChanged)
226 |
227 |   -- main module
228 |   main <- schExp empty (Chez.chezExtPrim empty defaultLaziness) Chez.chezString defaultLaziness 0 ctm
229 |   Core.writeFile (appdir </> "mainprog.ss") $ build $ sepBy "\n"
230 |     [ schHeader (map snd libs) [lib.name | lib <- chezLibs]
231 |     , collectRequestHandler
232 |     , main
233 |     , schFooter
234 |     ]
235 |
236 |   pure (supportChanged, chezLibs)
237 |
238 | makeSh : String -> String -> String -> String -> Core ()
239 | makeSh chez outShRel appDirSh targetSh =
240 |   Core.writeFile outShRel (startChez chez appDirSh targetSh)
241 |
242 | ||| Make Windows start scripts, one for bash environments and one batch file
243 | makeShWindows : String -> String -> String -> String -> Core ()
244 | makeShWindows chez outShRel appDirSh targetSh = do
245 |   let cmdFile = outShRel ++ ".cmd"
246 |   Core.writeFile cmdFile (startChezCmd chez appDirSh targetSh)
247 |   Core.writeFile outShRel (startChezWinSh chez appDirSh targetSh)
248 |
249 | ||| Chez Scheme implementation of the `compileExpr` interface.
250 | compileExpr :
251 |   Bool ->
252 |   Ref Ctxt Defs ->
253 |   Ref Syn SyntaxInfo ->
254 |   (tmpDir : String) -> (outputDir : String) ->
255 |   ClosedTerm -> (outfile : String) -> Core (Maybe String)
256 | compileExpr makeitso c s tmpDir outputDir tm outfile = do
257 |   -- set up paths
258 |   Just cwd <- coreLift currentDir
259 |        | Nothing => throw (InternalError "Can't get current directory")
260 |   let appDirSh  = outfile ++ "_app"  -- relative to the launcher shell script
261 |   let appDirRel = outputDir </> appDirSh  -- relative to CWD
262 |   let appDirAbs = cwd </> appDirRel
263 |   coreLift_ $ mkdirAll appDirRel
264 |
265 |   -- generate the code
266 |   chez <- coreLift $ findChez
267 |   (supportChanged, chezLibs) <- compileToSS c chez appDirRel tm
268 |
269 |   -- compile the code
270 |   logTime 2 "Make SO" $ when makeitso $ do
271 |     -- compile the support code
272 |     when supportChanged $ do
273 |       log "compiler.scheme.chez" 3 $ "Compiling support"
274 |       compileChezLibrary chez appDirRel (appDirRel </> "support.ss")
275 |
276 |     -- compile every compilation unit
277 |     compileChezLibraries chez appDirRel
278 |       [appDirRel </> lib.name <.> "ss" | lib <- chezLibs, lib.isOutdated]
279 |
280 |     -- touch them in the right order to make the timestamps right
281 |     -- even for the libraries that were not recompiled
282 |     for_ chezLibs $ \lib => do
283 |       log "compiler.scheme.chez" 3 $ "Touching " ++ lib.name
284 |       touch (appDirRel </> lib.name <.> "so")
285 |
286 |     -- compile the main program
287 |     compileChezProgram chez appDirRel (appDirRel </> "mainprog.ss")
288 |
289 |   -- generate the launch script
290 |   let outShRel = outputDir </> outfile
291 |   let launchTargetSh = appDirSh </> "mainprog" <.> (if makeitso then "so" else "ss")
292 |   if isWindows
293 |      then makeShWindows chez outShRel appDirSh launchTargetSh
294 |      else makeSh        chez outShRel appDirSh launchTargetSh
295 |   coreLift_ $ chmodRaw outShRel 0o755
296 |   pure (Just outShRel)
297 |
298 | ||| Chez Scheme implementation of the `executeExpr` interface.
299 | ||| This implementation simply runs the usual compiler, saving it to a temp file, then interpreting it.
300 | executeExpr :
301 |   Ref Ctxt Defs ->
302 |   Ref Syn SyntaxInfo ->
303 |   (tmpDir : String) -> ClosedTerm -> Core ()
304 | executeExpr c s tmpDir tm
305 |     = do Just sh <- compileExpr False c s tmpDir tmpDir tm "_tmpchez"
306 |             | Nothing => throw (InternalError "compileExpr returned Nothing")
307 |          coreLift_ $ system [sh]
308 |
309 | ||| Codegen wrapper for Chez scheme implementation.
310 | export
311 | codegenChezSep : Codegen
312 | codegenChezSep = MkCG (compileExpr True) executeExpr Nothing Nothing
313 |