Add StdIO module & clean up IO in TCB

This removes some derivable operations out of the TCB, e.g. `fprintln`
and `fprintlnWithLabels`. At the same time, `inputLine` has been
semi-generalised to be `freadln` (read a line from a file) and `stdin`
is now a derivable capability similar to the one needed for printing
to `stdout`. This also fixes the missing access to `stderr`.

For now, there are lots of `runtime/core` tests that rely on the
preamble functions, `print` and so on. In the long run, these tests
should be rewritten such that they are completely independent.

The tests for the preamble itself have been moved into a separate
folder.

Author: ssoelvsten

compiler/src/AddAmbientMethods.hs

@@ -1,47 +1,61 @@
 -- 2020-05-17, AA
 
 -- HACK
--- This module add a number of standard 
--- ambient methods such as `print` to the 
--- beginning of the file. This provides some
--- backward compatibility with prior test cases
--- as well as minimizes some clutter
-
--- If these methods are unused they are 
--- eliminated by the optimization passes in 
--- the further passes.
-
-module AddAmbientMethods(addAmbientMethods) where 
+--
+-- This module add a number of standard ambient methods such as `print` to the beginning of the
+-- file. This provides some backward compatibility with prior test cases as well as minimizes some
+-- clutter.
+--
+-- If these methods are unused they are eliminated by the optimization passes in the further passes.
+
+-- TODO
+--
+-- Move this into a '.trp' file of the form
+--
+-- ```
+--     let fun print x = fwrite (stdout authority, (toString x) ^"\n")
+--         ...
+--     in () end
+-- ```
+--
+-- Which, similar to below, after parsing has the `dummy` value replaced by the actual program. This
+-- preamble can then be specified at compile-time.
+
+module AddAmbientMethods(addAmbientMethods) where
 
 import Basics
-import Direct  
+import Direct
 import TroupePositionInfo
 
-printDecl :: FunDecl 
-printDecl = FunDecl "print"  
+printStringDecl :: FunDecl
+printStringDecl = FunDecl "printString"
     [Lambda [VarPattern "x"] $
-        Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos]
-            (App (Var "fprintln") [Tuple [Var "out", Var "x"]])
+        Let [ ValDecl (VarPattern "fd") (App (Var "stdout") [Var "authority"]) NoPos
+            , ValDecl (VarPattern "x'") (Bin Concat (Var "x") (Lit $ LString "\\n")) NoPos
+            ]
+            (App (Var "fwrite") [Tuple [Var "fd", Var "x'"]])
     ] NoPos
 
-printWithLabelsDecl :: FunDecl 
-printWithLabelsDecl = FunDecl "printWithLabels" 
-    [Lambda [VarPattern "x"] $
-        Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos]
-            (App (Var "fprintlnWithLabels") [Tuple [Var "out", Var "x"]])
+printDecl :: FunDecl
+printDecl = FunDecl "print"
+    [Lambda [ VarPattern "x" ] $
+      (App (Var "printString") [App (Var "toString") [Var "x"]])
     ] NoPos
 
-
-printStringDecl :: FunDecl 
-printStringDecl = FunDecl "printString"
-    [Lambda [VarPattern "x"] $
-        Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos]
-            (App (Var "fwrite") [Tuple [Var "out", Bin Concat (Var "x") (Lit (LString "\\n"))]])
+printWithLabelsDecl :: FunDecl
+printWithLabelsDecl = FunDecl "printWithLabels"
+    [Lambda [ VarPattern "x" ] $
+      (App (Var "printString") [App (Var "toStringL") [Var "x"]])
     ] NoPos
 
+inputLineDecl :: FunDecl
+inputLineDecl = FunDecl "inputLine"
+    [Lambda [ VarPattern "_" ] $
+        Let [ValDecl (VarPattern "fd") (App (Var "stdin") [Var "authority"]) NoPos]
+            (App (Var "freadln") [App (Var "stdin") [Var "authority"]])
+    ] NoPos
 
-
-addAmbientMethods :: Prog -> Prog 
-addAmbientMethods (Prog imports atoms t) = 
-    let t' = Let [FunDecs [printDecl,printWithLabelsDecl,printStringDecl]] t
-    in Prog imports atoms t'
+addAmbientMethods :: Prog -> Prog
+addAmbientMethods (Prog imports atoms t) =
+    let t' = Let [FunDecs [printStringDecl,printDecl,printWithLabelsDecl,inputLineDecl]] t
+    in Prog imports atoms t'

compiler/src/IR.hs

@@ -261,7 +261,7 @@ instance WellFormedIRCheck IRExpr where
     -- code over wire. Such malformed code would result
     -- in a JS output returning a runtime error (which should
     -- generally be avoided)
-     if  fname `elem`[ 
+     if  fname `elem`[
                        "$$authorityarg"
                      , "adv"
                      , "ladv"
@@ -285,16 +285,13 @@ instance WellFormedIRCheck IRExpr where
                      , "endorse"
                      , "floor"
                      , "flowsTo"                     
-                     , "fprintln"
-                     , "fprintlnWithLabels"
-                     , "fwrite"                     
+                     , "freadln"
+                     , "fwrite"
                      , "getTime"
                      , "getType"
                      , "getNanoTime"
-                     , "getStdout"
                      , "_getSystemProcess"
                      , "guard"
-                     , "inputLine"
                      , "intToString"                     
                      , "listToTuple"
                      , "lowermbox"                    
@@ -305,13 +302,13 @@ instance WellFormedIRCheck IRExpr where
                      , "newlabel"                     
                      , "node"
                      , "_pc"
+                     , "_bl"
                      , "pcpop"
                      , "peek"
                      , "pinipush"
                      , "pinipushto"
                      , "pinipop"
                      , "pcpush"                      
-                     , "question"
                      , "raisembox"
                      , "raiseTrust"
                      , "random"
@@ -333,6 +330,9 @@ instance WellFormedIRCheck IRExpr where
                      , "spawn"
                      , "sqrt"
                      , "substring"
+                     , "stdin"
+                     , "stdout"
+                     , "stderr"
                      , "stringToInt"
                      , "strlen"
                      , "restore"

lib/Makefile

@@ -6,6 +6,7 @@ build:
   # No dependencies
 	$(COMPILER) ./Number.trp -l
 	$(COMPILER) ./List.trp -l
+	$(COMPILER) ./StdIO.trp -l
 	$(COMPILER) ./ThreadUtil.trp -l
 
   # Dependency on `List`

lib/README.md

@@ -13,6 +13,7 @@ reviewed rigorously rather than depend on the monitor.
 - `List`           : Operations for lists, i.e. `[]` and `x::xs`.
 - `ListPair`       : Operations for list of pairs, i.e. `(x,y)::xs`.
 - `Number`         : Operations for numbers, i.e. integer and floats.
+- `StdIO`          : Standard input and output.
 - `StencilVector`  : Memory-efficient implementation of small (sparse) arrays.
 - `String`         : Operations for strings
 - `ThreadUtil`     : Additional functions for thread management.

lib/StdIO.trp

@@ -0,0 +1,121 @@
+let (** OS.IO module with file reading and writing.
+     *
+     * TODO: For now, this is only used internally for the StdIO library. But, when file reading and
+     * writing is properly added, then this needs to be moved to its own module. *)
+    fun OS_IO authority =
+        let (*--- File Reading ---*)
+            (* TODO: Sub-line input access. *)
+
+            (** Obtain the next line from `fd`.
+             *
+             *  This is merely reexposing the `freadln` language builtin.
+             **)
+            fun readln fd =
+                freadln fd
+
+            (** Similar to `readln` but ensures the blocking label is not raised. *)
+            fun readln' fd =
+                let pini authority
+                    val ln = readln fd
+                in ln end
+
+            (** Similar to `readln'` but declassifies what is read to the given level. *)
+            fun readlnAtLevel fd level =
+                declassify (readln' fd, authority, level)
+
+            (*--- File Writing ---*)
+            fun _write fd str = fwrite (fd, str)
+
+            (** Write `x` to the given file descriptor. *)
+            fun write fd x = case getType x of "string" => _write fd x
+                                             | _        => _write fd (toString x)
+
+            (** Write `x` and its security label(s) to the given file descriptor. *)
+            fun writeL fd x = _write fd (toStringL x)
+
+            (** Write `x` and a newline to the given file descriptor. *)
+            fun writeln fd x = (write fd x; _write fd "\n")
+
+            (** Write `x`, its security label(s), and a newline to the given file descriptor. *)
+            fun writelnL fd x = (writeL fd x; _write fd "\n")
+        in
+            { readln
+            , readln'
+            , readlnAtLevel
+            , write
+            , writeL
+            , writeln
+            , writelnL
+            }
+        end
+
+    (** Standard input and output handling. *)
+    fun StdIO authority =
+        let val OS = OS_IO authority
+
+            (*--- STD File Descriptors ---*)
+
+            (** Capability for standard input. *)
+            val stdin  = stdin authority
+
+            (** Capability for standard output. *)
+            val stdout = stdout authority
+
+            (** Capability for standard error. *)
+            val stderr = stderr authority
+
+            (*--- Input/Output ---*)
+
+            (** Write the given `question` to `stdout` and returns the answer provided from
+             *  `stdin`. *)
+            fun input question =
+                (OS.write stdout question; OS.readln stdin)
+
+            (** Similar to `input` but does not raise the blocking label. *)
+            fun input' question =
+                (OS.write stdout question; OS.readln' stdin)
+
+            (** Similar to `input'` but also declassifies the result. *)
+            fun inputAtLevel question level =
+                (OS.write stdout question; OS.readlnAtLevel stdin level)
+
+            (*--- Submodule(s) ---*)
+
+            (** Reading from `stdin`. *)
+            val In  =
+                { readln        = fn () => OS.readln  stdin
+                , readln'       = fn () => OS.readln' stdin
+                , readlnAtLevel = fn l  => OS.readlnAtLevel stdin l
+                }
+
+            (** Printing to `stdout`. *)
+            val Out =
+                { print    = OS.write    stdout
+                , println  = OS.writeln  stdout
+                , printL   = OS.writeL   stdout
+                , printlnL = OS.writelnL stdout
+                }
+
+            (** Printing to `stderr`. *)
+            val Err =
+                { print    = OS.write    stderr
+                , println  = OS.writeln  stderr
+                , printL   = OS.writeL   stderr
+                , printlnL = OS.writelnL stderr
+                }
+
+        in (*--- Module(s) ---*)
+            { stdin
+            , In
+            , stdout
+            , Out
+            , stderr
+            , Err
+            , input
+            , input'
+            , inputAtLevel
+            }
+        end
+
+in [ ("StdIO", StdIO) ]
+end

lib/Unit.trp

@@ -6,11 +6,11 @@ let
     fun print auth indent str =
         let fun makeIndent 0 = ""
               | makeIndent i = "  " ^ (makeIndent (i-1))
-        in fwrite ((getStdout auth), (makeIndent indent) ^ str)
+        in fwrite ((stdout auth), (makeIndent indent) ^ str)
         end
 
-    fun printCR auth = fwrite ((getStdout auth), "\r")
-    fun printNL auth = fwrite ((getStdout auth), "\n")
+    fun printCR auth = fwrite ((stdout auth), "\r")
+    fun printNL auth = fwrite ((stdout auth), "\n")
 
     (* TODO (Issue #55) Move colours into helper functions. *)
     val testStr = "\x1b[33m" ^ "[ TEST ]" ^ "\x1b[0m" ^ " it "

rt/src/Asserts.mts

@@ -34,6 +34,7 @@ function __stringRep (v) {
 }
 
 let err = x => _thread().threadError(x)
+
 export function assertIsAtom (x: any) {
     _thread().raiseBlockingThreadLev(x.tlev)
     if (x.val._troupeType != TroupeType.ATOM ) {
@@ -209,7 +210,6 @@ export function assertIsProcessId(x: any) {
     }
 }
 
-
 export function assertIsCapability(x: any) {
     _thread().raiseBlockingThreadLev(x.tlev);
     if (!(x.val instanceof Capability)) {
@@ -229,6 +229,7 @@ export function rawAssertIsLevel (x:any) {
         err("value " + __stringRep(x) + " is not a level");
     }
 }
+
 export function assertIsRootAuthority(x: any) {
     let isTop = actsFor(x.val.authorityLevel, levels.ROOT);
     if (!isTop) {

rt/src/UserRuntime.mts

@@ -19,6 +19,7 @@ import { BuiltinToString } from './builtins/toString.mjs'
 import { BuiltinSend } from './builtins/send.mjs'
 import { BuiltinSpawn } from './builtins/spawn.mjs'
 import { BuiltinReceive } from './builtins/receive.mjs'
+import { BuiltinThread } from './builtins/thread.mjs'
 import { BuiltinAttenuate } from './builtins/attenuate.mjs'
 import { BuiltinRegistry } from './builtins/whereis.mjs'
 import { BuiltinDeclassify } from './builtins/declassify.mjs'
@@ -46,6 +47,7 @@ export const UserRuntime =
     BuiltinRegistry(
     BuiltinAttenuate(
     BuiltSpawnSendReceive(
+    BuiltinThread(
     BuiltinStringToInt(
     BuiltinToString(
     BuiltinGetTime(
@@ -64,5 +66,5 @@ export const UserRuntime =
     BuiltinMath(
     BuiltinRecordReflection(
     BuiltinTypeInformation(
-    BuiltinStdIo(UserRuntimeZero)    
-    )))))))))))))))))))))))))))))
+    BuiltinStdIo(UserRuntimeZero)
+    ))))))))))))))))))))))))))))))

rt/src/builtins/receive.mts

@@ -131,19 +131,6 @@ export function BuiltinReceive<TBase extends Constructor<UserRuntimeZero>>(Base:
           return this.runtime.__mbox.consume ( consume_l, i.val, lowb.val, highb.val )
         })
 
-        _blockThread = mkBase ((arg) => {
-          assertIsUnit(arg)
-          this.runtime.__sched.blockThread(this.runtime.__sched.__currentThread);
-          return null;
-        })
-
-        _pc = mkBase ((arg) => {
-          assertIsUnit (arg)
-          return this.runtime.ret (
-            new LVal (this.runtime.$t.pc, this.runtime.$t.pc, BOT))
-        })
- 
-
         guard = mkBase (arg => {
           assertIsNTuple(arg, 3)
           let f = arg.val[0]