Rework racket based runtime/compilation

parser-typechecker/src/Unison/Runtime/Interface.hs

@@ -44,9 +44,16 @@ import Data.Set as Set
   )
 import Data.Set qualified as Set
 import Data.Text (isPrefixOf, unpack)
+import System.Directory
+  ( XdgDirectory(XdgCache),
+    createDirectoryIfMissing,
+    getXdgDirectory
+  )
+import System.FilePath ((<.>), (</>))
 import System.Process
   ( CreateProcess (..),
     StdStream (..),
+    callProcess,
     proc,
     waitForProcess,
     withCreateProcess,
@@ -476,8 +483,9 @@ nativeCompile ::
 nativeCompile _version ctxVar cl ppe base path = tryM $ do
   ctx <- readIORef ctxVar
   (tyrs, tmrs) <- collectRefDeps cl base
-  (_, codes) <- loadDeps cl ppe ctx tyrs tmrs
-  nativeCompileCodes codes base path
+  (ctx, codes) <- loadDeps cl ppe ctx tyrs tmrs
+  Just ibase <- pure $ baseToIntermed ctx base
+  nativeCompileCodes codes ibase path
 
 interpCompile ::
   Text ->
@@ -647,8 +655,8 @@ backReferenceTm ws frs irs dcm c i = do
   bs <- Map.lookup r dcm
   Map.lookup i bs
 
-schemeProc :: [String] -> CreateProcess
-schemeProc args =
+ucrProc :: [String] -> CreateProcess
+ucrProc args =
   (proc "native-compiler/bin/runner" args)
     { std_in = CreatePipe,
       std_out = Inherit,
@@ -696,23 +704,27 @@ nativeEvalInContext _ ctx codes base = do
       -- decodeResult . deserializeValue =<< BS.hGetContents pout
       callout _ _ _ _ =
         pure . Left $ "withCreateProcess didn't provide handles"
-  withCreateProcess (schemeProc []) callout
+  withCreateProcess (ucrProc []) callout
 
 nativeCompileCodes ::
   [(Reference, SuperGroup Symbol)] ->
   Reference ->
   FilePath ->
   IO ()
 nativeCompileCodes codes base path = do
+  genDir <- getXdgDirectory XdgCache "unisonlanguage/racket-tmp"
+  createDirectoryIfMissing True genDir
   let bytes = serializeValue . compileValue base $ codes
+      srcPath = genDir </> path <.> "rkt"
       callout (Just pin) _ _ ph = do
         BS.hPut pin . runPutS . putWord32be . fromIntegral $ BS.length bytes
         BS.hPut pin bytes
         UnliftIO.hClose pin
         waitForProcess ph
         pure ()
       callout _ _ _ _ = fail "withCreateProcess didn't provide handles"
-  withCreateProcess (schemeProc ["-o", path]) callout
+  withCreateProcess (ucrProc ["-G", srcPath]) callout
+  callProcess "raco" ["exe", "-o", path, srcPath]
 
 evalInContext ::
   PrettyPrintEnv ->

scheme-libs/racket/ucr.rkt

@@ -0,0 +1,111 @@
+#lang racket/base
+
+; This implements a standalone unison runtime, with options for
+; generating compilable racket modules.
+;
+; For runtime, it relies on the support for unison dynamic code
+; loading. It expects to be provided with a serialized list of term
+; links and associated code. It then loads the code in the same manner
+; as dynamic runtime execution, and evaluates a main definition.
+;
+; Since this is intended to be an implementation of evaluation for
+; e.g. ucm, the input is expected to be complete. No protocol is
+; implemented for negotiating with a host for additional needed
+; definitions. The program has all the built in definitions, and
+; everything else is expected to be provided in the initial input.
+;
+; In addition to this mode, it is possible to supply a command line
+; argument `-G` with a file name. This will instead produce a racket
+; file with the supplied definitions. This file should be suitable for
+; compilation and distribution with the `raco` tool, so long as the
+; supporting unison-on-racket libraries are known to the racket
+; install.
+
+(require
+  racket/pretty
+  (except-in racket false true unit any)
+  compiler/embed
+  unison/boot
+  unison/data
+  unison/data-info
+  unison/chunked-seq
+  unison/primops
+  unison/primops-generated
+  unison/builtin-generated)
+
+; Gets bytes using the expected input format. The format is simple:
+;
+;  - 4 bytes indicating how many bytes follow
+;  - the actual payload, with size matching the above
+(define (grab-bytes)
+  (let* ([size-bytes (read-bytes 4)]
+         [size (integer-bytes->integer size-bytes #f #t 0 4)])
+    (read-bytes size)))
+
+; Reads and decodes the input. First uses `grab-bytes` to read the
+; payload, then uses unison functions to deserialize the `Value` that
+; is expected.
+;
+; The `Value` is expected to be a pair of loadable code and which
+; definition should be executed. In unison types, it is:
+;
+;   ([(Link.Term, Code)], Link.Term)
+(define (decode-input)
+  (let ([bs (grab-bytes)])
+    (match (builtin-Value.deserialize (bytes->chunked-bytes bs))
+      [(unison-data _ t (list q))
+       (= t unison-either-right:tag)
+       (apply
+         values
+         (unison-tuple->list (reify-value (unison-quote-val q))))]
+      [else
+        (raise "unexpected input")])))
+
+; Implements the evaluation mode of operation. First decodes the
+; input. Then uses the dynamic loading machinery to add the code to
+; the runtime. Finally executes a specified main reference.
+(define (do-evaluate)
+  (let-values ([(code main-ref) (decode-input)])
+    (add-runtime-code 'unison-main code)
+    (handle ['ref-4n0fgs00] top-exn-handler
+            ((termlink->proc main-ref))
+            (data 'unit 0))))
+
+; Uses racket pretty printing machinery to instead generate a file
+; containing the given code, and which executes the main definition on
+; loading. This file can then be built with `raco exe`.
+(define (write-module srcf main-ref icode)
+  (call-with-output-file
+    srcf
+    (lambda (port)
+      (parameterize ([print-as-expression #t])
+        (display "#lang racket/base\n\n" port)
+
+        (for ([expr (build-intermediate-module main-ref icode)])
+          (pretty-print expr port 1)
+          (newline port))
+        (newline port)))
+    #:exists 'replace))
+
+; Decodes input and writes a module to the specified file.
+(define (do-generate srcf)
+  (define-values (icode main-ref) (decode-input))
+  (write-module srcf main-ref icode))
+
+(define generate-to (make-parameter #f))
+
+(define (handle-command-line)
+  (command-line
+    #:program "ucr"
+    #:once-any
+    [("-G" "--generate-file")
+       file
+       "generate code to <file>"
+       (generate-to file)]
+    #:args ()
+    (generate-to)))
+
+(let ([out (handle-command-line)])
+  (if out
+    (do-generate out)
+    (do-evaluate)))

scheme-libs/racket/unison/primops-generated.rkt

@@ -49,6 +49,7 @@
   termlink->name
 
   add-runtime-code
+  build-intermediate-module
   build-runtime-module
   termlink->proc)
 
@@ -558,6 +559,32 @@
        (parameterize ([current-namespace runtime-namespace])
          (dynamic-require `(quote ,mname) sym)))]))
 
+; Straight-line module builder given intermediate definitions.
+; This expects to receive a list of termlink, code pairs, and
+; generates a scheme module that contains the corresponding
+; definitions.
+(define (build-intermediate-module primary dfns0)
+  (let* ([udefs (chunked-list->list dfns0)]
+         [pname (termlink->name primary)]
+         [tmlinks (map ufst udefs)]
+         [codes (map usnd udefs)]
+         [tylinks (gen-typelinks codes)]
+         [sdefs (flatten (map gen-code udefs))])
+    `((require unison/boot
+               unison/data-info
+               unison/primops
+               unison/primops-generated
+               unison/builtin-generated
+               unison/simple-wrappers
+               unison/compound-wrappers)
+
+      ,@tylinks
+
+      ,@sdefs
+
+      (handle ['ref-4n0fgs00] top-exn-handler
+              (,pname #f)))))
+
 (define (build-runtime-module mname tylinks tmlinks defs)
   (let ([names (map termlink->name tmlinks)])
     `(module ,mname racket/base

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -971,7 +971,7 @@ loop e = do
               when (not updated) (Cli.respond $ NothingToPatch patchPath scopePath')
             ExecuteI main args -> handleRun False main args
             MakeStandaloneI output main -> doCompile False output main
-            CompileSchemeI output main -> doCompileScheme output main
+            CompileSchemeI output main -> doCompile True output main
             ExecuteSchemeI main args -> doRunAsScheme main args
             GenSchemeLibsI mdir ->
               doGenerateSchemeBoot True Nothing mdir
@@ -2071,21 +2071,21 @@ runScheme file args = do
   unless success $
     Cli.returnEarly (PrintMessage "Scheme evaluation failed.")
 
-buildScheme :: String -> String -> Cli ()
-buildScheme main file = do
-  ensureSchemeExists
-  statDir <- getSchemeStaticLibDir
-  genDir <- getSchemeGenLibDir
-  buildRacket genDir statDir main file
-
-buildRacket :: String -> String -> String -> String -> Cli ()
-buildRacket genDir statDir main file =
-  let args = ["-l", "raco", "--", "exe", "-o", main, file]
-      opts = racketOpts genDir statDir args
-   in void . liftIO $
-        catch
-          (True <$ callProcess "racket" opts)
-          (\(_ :: IOException) -> pure False)
+-- buildScheme :: String -> String -> Cli ()
+-- buildScheme main file = do
+--   ensureSchemeExists
+--   statDir <- getSchemeStaticLibDir
+--   genDir <- getSchemeGenLibDir
+--   buildRacket genDir statDir main file
+
+-- buildRacket :: String -> String -> String -> String -> Cli ()
+-- buildRacket genDir statDir main file =
+--   let args = ["-l", "raco", "--", "exe", "-o", main, file]
+--       opts = racketOpts genDir statDir args
+--    in void . liftIO $
+--         catch
+--           (True <$ callProcess "racket" opts)
+--           (\(_ :: IOException) -> pure False)
 
 doCompile :: Bool -> String -> HQ.HashQualified Name -> Cli ()
 doCompile native output main = do
@@ -2111,9 +2111,9 @@ doRunAsScheme main0 args = case HQ.fromString main0 of
     runScheme fullpath args
   Nothing -> Cli.respond $ BadName main0
 
-doCompileScheme :: String -> HQ.HashQualified Name -> Cli ()
-doCompileScheme out main =
-  generateSchemeFile True out main >>= buildScheme out
+-- doCompileScheme :: String -> HQ.HashQualified Name -> Cli ()
+-- doCompileScheme out main =
+--   generateSchemeFile True out main >>= buildScheme out
 
 generateSchemeFile :: Bool -> String -> HQ.HashQualified Name -> Cli String
 generateSchemeFile exec out main = do

unison-src/transcripts-manual/gen-racket-libs.md

@@ -0,0 +1,9 @@
+
+Fetch base, then fetch the compiler, then build the generated
+libraries in the racket directory.
+
+```ucm
+.> pull @unison/base/releases/2.5.0 .base
+.> compile.native.fetch
+.> compile.native.genlibs scheme-libs/racket
+```