Miscellaneous JIT fixes

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

@@ -55,6 +55,7 @@ import System.Directory
     createDirectoryIfMissing,
     getXdgDirectory,
   )
+import System.Environment (getArgs)
 import System.Exit (ExitCode (..))
 import System.FilePath ((<.>), (</>))
 import System.Process
@@ -869,6 +870,8 @@ nativeEvalInContext executable ppe ctx serv port codes base = do
   ensureRuntimeExists executable
   let cc = ccache ctx
   crs <- readTVarIO $ combRefs cc
+  -- Seems a bit weird, but apparently this is how we do it
+  args <- getArgs
   let bytes = serializeValue . compileValue base $ codes
 
       decodeResult (Error msg) = pure . Left $ text msg
@@ -884,8 +887,14 @@ nativeEvalInContext executable ppe ctx serv port codes base = do
             (errs, dv) -> pure $ Right (listErrors errs, dv)
 
       comm mv (sock, _) = do
-        send sock . runPutS . putWord32be . fromIntegral $ BS.length bytes
+        let encodeNum = runPutS . putWord32be . fromIntegral
+        send sock . encodeNum $ BS.length bytes
         send sock bytes
+        send sock . encodeNum $ length args
+        for_ args $ \arg -> do
+          let bs = encodeUtf8 $ pack arg
+          send sock . encodeNum $ BS.length bs
+          send sock bs
         UnliftIO.putMVar mv =<< receiveAll sock
 
       callout _ _ _ ph = do

scheme-libs/racket/unison-runtime.rkt

@@ -33,15 +33,28 @@
   unison/primops-generated
   unison/builtin-generated)
 
+(define (grab-num port)
+  (integer-bytes->integer (read-bytes 4 port) #f #t 0 4))
+
 ; 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 port)
-  (let* ([size-bytes (read-bytes 4 port)]
-         [size (integer-bytes->integer size-bytes #f #t 0 4)])
+  (let ([size (grab-num port)])
     (read-bytes size port)))
 
+; Gets args sent after the code payload. Format is:
+;
+; - 4 bytes indicating how many arguments
+; - for each argument
+;   - 4 bytes indicating length of argument
+;   - utf-8 bytes of that length
+(define (grab-args port)
+  (let ([n (grab-num port)])
+    (for/list ([i (range n)])
+      (bytes->string/utf-8 (grab-bytes port)))))
+
 ; Reads and decodes the input. First uses `grab-bytes` to read the
 ; payload, then uses unison functions to deserialize the `Value` that
 ; is expected.
@@ -113,13 +126,15 @@
 ; input. Then uses the dynamic loading machinery to add the code to
 ; the runtime. Finally executes a specified main reference.
 (define (do-evaluate in out)
-  (let-values ([(code main-ref) (decode-input in)])
+  (let-values ([(code main-ref) (decode-input in)]
+               [(args) (list->vector (grab-args in))])
     (add-runtime-code 'unison-main code)
     (with-handlers
       ([exn:bug? (lambda (e) (encode-error e out))])
 
-      (handle [ref-exception:typelink] (eval-exn-handler out)
-              ((termlink->proc main-ref))))))
+      (parameterize ([current-command-line-arguments args])
+        (handle [ref-exception:typelink] (eval-exn-handler out)
+                ((termlink->proc main-ref)))))))
 
 ; Uses racket pretty printing machinery to instead generate a file
 ; containing the given code, and which executes the main definition on

scheme-libs/racket/unison/core.ss

@@ -37,7 +37,6 @@
   bytevector
   bytevector-append
 
-  directory-contents
   current-microseconds
 
   decode-value
@@ -227,10 +226,6 @@
 (define (current-microseconds)
   (fl->fx (* 1000 (current-inexact-milliseconds))))
 
-(define (directory-contents path-str)
-  (define (extract path) (string->chunked-string (path->string path)))
-  (map extract (directory-list (chunked-string->string path-str))))
-
 (define (list-head l n)
   (let rec ([c l] [m n])
     (cond
@@ -476,19 +471,17 @@
           (next (fx1- i)))))))
 
 (define (write-exn:bug ex port mode)
-  (when mode
-    (write-string "<exn:bug " port))
+  (when mode (write-string "<exn:bug " port))
 
   (let ([recur (case mode
                  [(#t) write]
                  [(#f) display]
                  [else (lambda (v port) (print v port mode))])])
-    (recur (chunked-string->string (exn:bug-msg ex)) port)
+    (recur (exn:bug-msg ex) port)
     (if mode (write-string " " port) (newline port))
     (write-string (describe-value (exn:bug-val ex)) port))
 
-  (when mode
-    (write-string ">")))
+  (when mode (write-string ">" port)))
 
 (struct exn:bug (msg val)
   #:constructor-name make-exn:bug

scheme-libs/racket/unison/io-handles.rkt

@@ -14,6 +14,7 @@
 
 (provide
  unison-FOp-IO.stdHandle
+ unison-FOp-IO.openFile.impl.v3
  (prefix-out
   builtin-IO.
   (combine-out
@@ -100,13 +101,23 @@
           ref-unit-unit)
         (ref-either-right char))))
 
-(define-unison (getSomeBytes.impl.v1 handle bytes)
-  (let* ([buffer (make-bytes bytes)]
+(define-unison (getSomeBytes.impl.v1 handle nbytes)
+  (let* ([buffer (make-bytes nbytes)]
          [line (read-bytes-avail! buffer handle)])
-    (if (eof-object? line)
-        (ref-either-right (bytes->chunked-bytes #""))
-        (ref-either-right (bytes->chunked-bytes buffer))
-        )))
+    (cond
+      [(eof-object? line)
+       (ref-either-right (bytes->chunked-bytes #""))]
+      [(procedure? line)
+       (Exception
+         ref-iofailure:typelink
+         "getSomeBytes.impl: special value returned"
+         ref-unit-unit)]
+      [else
+       (ref-either-right
+         (bytes->chunked-bytes
+           (if (< line nbytes)
+             (subbytes buffer 0 line)
+             buffer)))])))
 
 (define-unison (getBuffering.impl.v3 handle)
     (case (file-stream-buffer-mode handle)
@@ -194,6 +205,15 @@
             (ref-either-right
               (string->chunked-string (bytes->string/utf-8 value))))))
 
+(define (unison-FOp-IO.openFile.impl.v3 fn0 mode)
+  (define fn (chunked-string->string fn0))
+
+  (right (case mode
+    [(0) (open-input-file fn)]
+    [(1) (open-output-file fn #:exists 'truncate)]
+    [(2) (open-output-file fn #:exists 'append)]
+    [else (open-input-output-file fn #:exists 'can-update)])))
+
 ;; From https://github.com/sorawee/shlex/blob/5de06500e8c831cfc8dffb99d57a76decc02c569/main.rkt (MIT License)
 ;; with is a port of https://github.com/python/cpython/blob/bf2f76ec0976c09de79c8827764f30e3b6fba776/Lib/shlex.py#L325
 (define unsafe-pattern #rx"[^a-zA-Z0-9_@%+=:,./-]")

scheme-libs/racket/unison/io.rkt

@@ -5,13 +5,18 @@
          unison/data-info
          racket/file
          racket/flonum
+         (only-in racket
+           date-dst?
+           date-time-zone-offset
+           date*-time-zone-name)
          (only-in unison/boot data-case define-unison)
          (only-in
            rnrs/arithmetic/flonums-6
            flmod))
 (require racket/file)
 
 (provide
+ builtin-Clock.internals.systemTimeZone.v1
  (prefix-out
   unison-FOp-Clock.internals.
   (combine-out
@@ -35,13 +40,21 @@
         renameFile.impl.v3
         createDirectory.impl.v3
         removeDirectory.impl.v3
+        directoryContents.impl.v3
         setCurrentDirectory.impl.v3
         renameDirectory.impl.v3
         isDirectory.impl.v3
         systemTime.impl.v3
         systemTimeMicroseconds.impl.v3
         createTempDirectory.impl.v3)))
 
+(define (failure-result ty msg vl)
+  (ref-either-left
+    (ref-failure-failure
+      ty
+      (string->chunked-string msg)
+      (unison-any-any vl))))
+
 (define (getFileSize.impl.v3 path)
     (with-handlers
         [[exn:fail:filesystem?
@@ -81,6 +94,24 @@
     (current-directory (chunked-string->string path))
     (ref-either-right none))
 
+(define-unison (directoryContents.impl.v3 path)
+  (with-handlers
+    [[exn:fail:filesystem?
+       (lambda (e)
+         (failure-result
+           ref-iofailure:typelink
+           (exception->string e)
+           ref-unit-unit))]]
+    (let* ([dirps (directory-list (chunked-string->string path))]
+           [dirss (map path->string dirps)])
+      (ref-either-right
+        (vector->chunked-list
+          (list->vector
+            (map
+              string->chunked-string
+              (list* "." ".." dirss))))))))
+
+
 (define-unison (createTempDirectory.impl.v3 prefix)
     (ref-either-right
         (string->chunked-string
@@ -117,6 +148,14 @@
 (define-unison (systemTimeMicroseconds.impl.v3 unit)
     (ref-either-right (inexact->exact (* 1000 (current-inexact-milliseconds)))))
 
+(define-unison (builtin-Clock.internals.systemTimeZone.v1 secs)
+  (let* ([d (seconds->date secs)])
+    (list->unison-tuple
+      (list
+        (date-time-zone-offset d)
+        (if (date-dst? d) 1 0)
+        (date*-time-zone-name d)))))
+
 (define (threadCPUTime.v1)
   (right
     (integer->time

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

@@ -304,8 +304,24 @@
   (match v
     [(unison-data _ t (list rf rt bs0))
      #:when (= t ref-value-data:tag)
-     (let ([bs (map reify-value (chunked-list->list bs0))])
-       (make-data (reference->typelink rf) rt bs))]
+     (let ([bs (map reify-value (chunked-list->list bs0))]
+           [tl (reference->typelink rf)])
+       (cond
+         [(eqv? tl builtin-boolean:typelink)
+          (cond
+            [(not (null? bs))
+             (raise
+               (make-exn:bug
+                 "reify-value: boolean with arguments"
+                 bs0))]
+            [(= rt 0) #f]
+            [(= rt 1) #t]
+            [else
+             (raise
+               (make-exn:bug
+                 "reify-value: unknown boolean tag"
+                 rt))])]
+         [else (make-data tl rt bs)]))]
     [(unison-data _ t (list gr bs0))
      #:when (= t ref-value-partial:tag)
      (let ([bs (map reify-value (chunked-list->list bs0))]
@@ -316,11 +332,18 @@
      (reify-vlit vl)]
     [(unison-data _ t (list bs0 k))
      #:when (= t ref-value-cont:tag)
-     (raise "reify-value: unimplemented cont case")]
+     (raise
+       (make-exn:bug
+         "reify-value: unimplemented cont case"
+         ref-unit-unit))]
     [(unison-data r t fs)
-     (raise "reify-value: unimplemented data case")]
+     (raise
+       (make-exn:bug
+         "reify-value: unrecognized tag"
+         ref-unit-unit))]
     [else
-      (raise (format "reify-value: unknown tag"))]))
+     (raise
+       (make-exn:bug "reify-value: unrecognized value" v))]))
 
 (define (reflect-typelink tl)
   (match tl
@@ -354,6 +377,11 @@
 
 (define (reflect-value v)
   (match v
+    [(? boolean?)
+     (ref-value-data
+       (reflect-typelink builtin-boolean:typelink)
+       (if v 1 0) ; boolean pseudo-data tags
+       empty-chunked-list)]
     [(? exact-nonnegative-integer?)
      (ref-value-vlit (ref-vlit-pos v))]
     [(? exact-integer?)

scheme-libs/racket/unison/primops.ss

@@ -314,13 +314,16 @@
     unison-FOp-Clock.internals.processCPUTime.v1
     unison-FOp-Clock.internals.realtime.v1
     unison-FOp-Clock.internals.monotonic.v1
+    builtin-Clock.internals.systemTimeZone.v1
+    builtin-Clock.internals.systemTimeZone.v1:termlink
 
 
     ; unison-FOp-Value.serialize
     unison-FOp-IO.stdHandle
     unison-FOp-IO.getArgs.impl.v1
 
-    unison-FOp-IO.directoryContents.impl.v3
+    builtin-IO.directoryContents.impl.v3
+    builtin-IO.directoryContents.impl.v3:termlink
     unison-FOp-IO.systemTimeMicroseconds.v1
 
     unison-FOp-ImmutableArray.copyTo!
@@ -732,6 +735,7 @@
   (define-builtin-link IO.getEnv.impl.v1)
   (define-builtin-link IO.getChar.impl.v1)
   (define-builtin-link IO.getCurrentDirectory.impl.v3)
+  (define-builtin-link IO.directoryContents.impl.v3)
   (define-builtin-link IO.removeDirectory.impl.v3)
   (define-builtin-link IO.renameFile.impl.v3)
   (define-builtin-link IO.createTempDirectory.impl.v3)
@@ -758,6 +762,7 @@
   (define-builtin-link Char.Class.is)
   (define-builtin-link Scope.bytearrayOf)
   (define-builtin-link unsafe.coerceAbilities)
+  (define-builtin-link Clock.internals.systemTimeZone.v1)
 
   (begin-encourage-inline
     (define-unison (builtin-Value.toBuiltin v) (unison-quote v))
@@ -1097,11 +1102,6 @@
     (define (unison-FOp-IO.getArgs.impl.v1)
       (sum 1 (cdr (command-line))))
 
-    (define (unison-FOp-IO.directoryContents.impl.v3 path)
-      (reify-exn
-        (lambda ()
-          (sum 1 (directory-contents path)))))
-
     (define unison-FOp-IO.systemTimeMicroseconds.v1 current-microseconds)
 
     ;; TODO should we convert Bytes -> Text directly without the intermediate conversions?
@@ -1131,13 +1131,6 @@
           (close-output-port h))
       (right none))
 
-    (define (unison-FOp-IO.openFile.impl.v3 fn mode)
-      (right (case mode
-        [(0) (open-file-input-port (chunked-string->string fn))]
-        [(1) (open-file-output-port (chunked-string->string fn))]
-        [(2) (open-file-output-port (chunked-string->string fn) 'no-truncate)]
-        [else (open-file-input/output-port (chunked-string->string fn))])))
-
     (define (unison-FOp-Text.repeat n t)
       (let loop ([cnt 0]
                  [acc empty-chunked-string])
@@ -1472,6 +1465,7 @@
   (declare-builtin-link builtin-IO.getArgs.impl.v1)
   (declare-builtin-link builtin-IO.getEnv.impl.v1)
   (declare-builtin-link builtin-IO.getChar.impl.v1)
+  (declare-builtin-link builtin-IO.directoryContents.impl.v3)
   (declare-builtin-link builtin-IO.getCurrentDirectory.impl.v3)
   (declare-builtin-link builtin-IO.removeDirectory.impl.v3)
   (declare-builtin-link builtin-IO.renameFile.impl.v3)
@@ -1497,4 +1491,5 @@
   (declare-builtin-link builtin-Char.Class.is)
   (declare-builtin-link builtin-Pattern.many.corrected)
   (declare-builtin-link builtin-unsafe.coerceAbilities)
+  (declare-builtin-link builtin-Clock.internals.systemTimeZone.v1)
   )