Merge pull request #84 from ssoelvsten/fork/dev/lib-cleanup

lib/ cleanup

Author: aslanix

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"))]])
+printLDecl :: FunDecl
+printLDecl = FunDecl "printL"
+    [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,printLDecl,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"

examples/fromuserguide/basic_lib.trp

@@ -1,4 +1,4 @@
 import List
-printWithLabels (List.map ( fn i => i + 1) [1,2,3])
+printL (List.map ( fn i => i + 1) [1,2,3])
 
 

examples/fromuserguide/basic_receive.trp

@@ -1,5 +1,5 @@
 let fun foo () =
-      receive [hn x => printWithLabels ("foo received", x)]
+      receive [hn x => printL ("foo received", x)]
     val p = spawn foo
 in send (p, "hello")
 end

examples/fromuserguide/basic_spawn.trp

@@ -1,5 +1,5 @@
 import List
-let fun printwait x = let val _ = printWithLabels x in sleep 10 end
+let fun printwait x = let val _ = printL x in sleep 10 end
     fun foo () = List.map printwait [1,2,3]
     fun bar () = List.map printwait ["A", "B", "C"]
 in  (spawn foo, spawn bar)

examples/fromuserguide/basic_updateableserver.trp

@@ -1,4 +1,5 @@
-import timeout
+import ThreadUtil
+
 let fun v_one n =
          receive [ hn ("REQUEST", senderid) => 
                         let val _ = send (senderid, n) 
@@ -26,7 +27,8 @@ let fun v_one n =
     val _ = send (service, ("UPDATE", v_two))
     val _ = send (service, ("COMPUTE", self(), fn x => x * x, 42))
     val _ = receive [ hn x => print x]
-in exitAfterTimeout 
-        authority 1000 0 "force terminating the server example after 1s"
+in ThreadUtil.spawnTimeout (fn () => print "force terminating the server example after 1s";
+                                     exit (authority, 0))
+                           1000
 end    
 

examples/fromuserguide/ifc_type_labels.trp

@@ -5,10 +5,10 @@ let val x = 100 raisedTo `{alice}`
                 val a = if y > 10 then z else "not an integer"
             in a 
             end
-    val _ = printWithLabels a
+    val _ = printL a
     val _ = debugpc()
     val w = a + x
-    val _ = printWithLabels w
+    val _ = printL w
 in debugpc()
 end
 

lib/DeclassifyUtil.trp

@@ -0,0 +1,110 @@
+import List
+
+let (* Mutually recursive deep declassification of tuples, lists, ... *)
+
+    (* Declassification for (most) tuples *)
+    fun declassify2 ((x,y), a, lev) =
+        ( declassifyDeep (x, a, lev)
+        , declassifyDeep (y, a, lev))
+
+    and declassify3 ((x,y,z), a, lev) =
+        ( declassifyDeep (x, a, lev)
+        , declassifyDeep (y, a, lev)
+        , declassifyDeep (z, a, lev))
+
+    and declassify4 ((x,y,z,w), a, lev) =
+        ( declassifyDeep (x, a, lev)
+        , declassifyDeep (y, a, lev)
+        , declassifyDeep (z, a, lev)
+        , declassifyDeep (w, a, lev))
+
+    and declassify5 ((x1,x2,x3,x4,x5), a, lev) =
+        ( declassifyDeep (x1, a, lev)
+        , declassifyDeep (x2, a, lev)
+        , declassifyDeep (x3, a, lev)
+        , declassifyDeep (x4, a, lev)
+        , declassifyDeep (x5, a, lev)
+        )
+
+    and declassify6 ((x1,x2,x3,x4,x5,x6), a, lev) =
+        ( declassifyDeep (x1, a, lev)
+        , declassifyDeep (x2, a, lev)
+        , declassifyDeep (x3, a, lev)
+        , declassifyDeep (x4, a, lev)
+        , declassifyDeep (x5, a, lev)
+        , declassifyDeep (x6, a, lev)
+        )
+
+    and declassify7 ((x1,x2,x3,x4,x5,x6,x7), a, lev) =
+        ( declassifyDeep (x1, a, lev)
+        , declassifyDeep (x2, a, lev)
+        , declassifyDeep (x3, a, lev)
+        , declassifyDeep (x4, a, lev)
+        , declassifyDeep (x5, a, lev)
+        , declassifyDeep (x6, a, lev)
+        , declassifyDeep (x7, a, lev)
+        )
+
+    and declassify8 ((x1,x2,x3,x4,x5,x6,x7,x8), a, lev) =
+        ( declassifyDeep (x1, a, lev)
+        , declassifyDeep (x2, a, lev)
+        , declassifyDeep (x3, a, lev)
+        , declassifyDeep (x4, a, lev)
+        , declassifyDeep (x5, a, lev)
+        , declassifyDeep (x6, a, lev)
+        , declassifyDeep (x7, a, lev)
+        , declassifyDeep (x8, a, lev)
+        )
+
+    and declassify9 ((x1,x2,x3,x4,x5,x6,x7,x8,x9), a, lev) =
+        ( declassifyDeep (x1, a, lev)
+        , declassifyDeep (x2, a, lev)
+        , declassifyDeep (x3, a, lev)
+        , declassifyDeep (x4, a, lev)
+        , declassifyDeep (x5, a, lev)
+        , declassifyDeep (x6, a, lev)
+        , declassifyDeep (x7, a, lev)
+        , declassifyDeep (x8, a, lev)
+        , declassifyDeep (x9, a, lev)
+        )
+
+    (* Declassification for lists *)
+    and declassifyList (xs, a, lev) =
+        List.map (fn x => declassifyDeep (x, a, lev) ) xs
+
+    (* TODO: Declassification of records? *)
+
+    (** Deep declassification of value `x` to `level` via the given `authority`. *)
+    and declassifyDeep (x, authority, level) =
+        let (* Declassify the blocking label before touching the value. *)
+            val _ = blockdeclto (authority, level)
+
+            (* declassification is a 2-step process:
+             *
+             * 1. We pattern match on the given value and figure out which function to apply;
+             *    this choice of the function needs to be declassified itself.
+             *
+             * 2. We proceed onto the application of the function. *)
+            val x' = declassify (x, authority, level)
+
+            val f = case x' of (_,_)               => declassify2
+                             | (_,_,_)             => declassify3
+                             | (_,_,_,_)           => declassify4
+                             | (_,_,_,_,_)         => declassify5
+                             | (_,_,_,_,_,_)       => declassify6
+                             | (_,_,_,_,_,_,_)     => declassify7
+                             | (_,_,_,_,_,_,_,_)   => declassify8
+                             | (_,_,_,_,_,_,_,_,_) => declassify9
+                             | (_::_)              => declassifyList
+                             | _                   => declassify
+
+        in f(x', authority, level)
+        end
+
+    (*--- Module ---*)
+    val DeclassifyUtil = {
+        declassifyDeep
+    }
+
+in [ ("DeclassifyUtil", DeclassifyUtil) ]
+end

lib/Hash.trp

@@ -10,15 +10,15 @@ let
      *)
     fun hashString s =
         (* String hash with fast paths for small strings *)
-        let val len = strlen s
-            val radix = 127
-            fun charCodeAt i = String.subCode (s,i)
+        let val len    = String.size s
+            val radix  = 127
+            val codeAt = String.sub' s
         in case len of 0 => 0
-                     | 1 => charCodeAt 0
-                     | 2 => (radix * charCodeAt 0 + charCodeAt 1) andb Number.maxInt32
+                     | 1 => codeAt 0
+                     | 2 => (radix * codeAt 0 + codeAt 1) andb Number.maxInt32
                      | _ => let fun go idx acc =
                                     if len <= idx then acc
-                                    else go (idx + 1) ((acc * radix + charCodeAt idx) andb Number.maxInt32)
+                                    else go (idx + 1) ((acc * radix + codeAt idx) andb Number.maxInt32)
                             in go 0 0
                             end
         end

lib/List.trp

@@ -72,9 +72,9 @@ let (* -- List Access -- *)
     (** Same as `List.map` but `f` is applied to the index of the element as first argument
         (counting from 0), and the element itself as second argument. Not tail-recursive. *)
     fun mapi f list =
-        let fun mapj j []    = []
-              | mapj j x::xs = (f (j,x)) :: (mapj (j+1) xs)
-        in mapj 0 list
+        let fun mapi_aux j []    = []
+              | mapi_aux j x::xs = (f (j,x)) :: (mapi_aux (j+1) xs)
+        in mapi_aux 0 list
         end
 
     (* TODO: revMap *)
@@ -83,6 +83,9 @@ let (* -- List Access -- *)
     fun foldl f y []    = y
       | foldl f y x::xs = foldl f (f (x,y)) xs
 
+    (** Left-fold of `f` on a non-empty list using the head as the initial value. *)
+    fun foldl1 f x::xs = foldl f x xs
+
     (* TODO: foldr *)
 
     (** Returns the sublist of elements that satisfy `f`. Not tail-recursive. *)
@@ -183,6 +186,7 @@ let (* -- List Access -- *)
         map,
         mapi,
         foldl,
+        foldl1,
         filter,
         filteri,
         partition,