Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
78 changes: 32 additions & 46 deletions compiler/src/AddAmbientMethods.hs
Original file line number Diff line number Diff line change
@@ -1,61 +1,47 @@
-- 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.

-- 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
-- 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

import Basics
import Direct
import Direct
import TroupePositionInfo

printStringDecl :: FunDecl
printStringDecl = FunDecl "printString"
printDecl :: FunDecl
printDecl = FunDecl "print"
[Lambda [VarPattern "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'"]])
Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos]
(App (Var "fprintln") [Tuple [Var "out", Var "x"]])
] NoPos

printDecl :: FunDecl
printDecl = FunDecl "print"
[Lambda [ VarPattern "x" ] $
(App (Var "printString") [App (Var "toString") [Var "x"]])
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"]])
] NoPos

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"]])
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"))]])
] NoPos

addAmbientMethods :: Prog -> Prog
addAmbientMethods (Prog imports atoms t) =
let t' = Let [FunDecs [printStringDecl,printDecl,printLDecl,inputLineDecl]] t
in Prog imports atoms t'


addAmbientMethods :: Prog -> Prog
addAmbientMethods (Prog imports atoms t) =
let t' = Let [FunDecs [printDecl,printWithLabelsDecl,printStringDecl]] t
in Prog imports atoms t'
14 changes: 7 additions & 7 deletions compiler/src/IR.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand All @@ -285,13 +285,16 @@ instance WellFormedIRCheck IRExpr where
, "endorse"
, "floor"
, "flowsTo"
, "freadln"
, "fwrite"
, "fprintln"
, "fprintlnWithLabels"
, "fwrite"
, "getTime"
, "getType"
, "getNanoTime"
, "getStdout"
, "_getSystemProcess"
, "guard"
, "inputLine"
, "intToString"
, "listToTuple"
, "lowermbox"
Expand All @@ -302,13 +305,13 @@ instance WellFormedIRCheck IRExpr where
, "newlabel"
, "node"
, "_pc"
, "_bl"
, "pcpop"
, "peek"
, "pinipush"
, "pinipushto"
, "pinipop"
, "pcpush"
, "question"
, "raisembox"
, "raiseTrust"
, "random"
Expand All @@ -330,9 +333,6 @@ instance WellFormedIRCheck IRExpr where
, "spawn"
, "sqrt"
, "substring"
, "stdin"
, "stdout"
, "stderr"
, "stringToInt"
, "strlen"
, "restore"
Expand Down
2 changes: 1 addition & 1 deletion examples/fromuserguide/basic_lib.trp
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
import List
printL (List.map ( fn i => i + 1) [1,2,3])
printWithLabels (List.map ( fn i => i + 1) [1,2,3])


2 changes: 1 addition & 1 deletion examples/fromuserguide/basic_receive.trp
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
let fun foo () =
receive [hn x => printL ("foo received", x)]
receive [hn x => printWithLabels ("foo received", x)]
val p = spawn foo
in send (p, "hello")
end
2 changes: 1 addition & 1 deletion examples/fromuserguide/basic_spawn.trp
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
import List
let fun printwait x = let val _ = printL x in sleep 10 end
let fun printwait x = let val _ = printWithLabels 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)
Expand Down
8 changes: 3 additions & 5 deletions examples/fromuserguide/basic_updateableserver.trp
Original file line number Diff line number Diff line change
@@ -1,5 +1,4 @@
import ThreadUtil

import timeout
let fun v_one n =
receive [ hn ("REQUEST", senderid) =>
let val _ = send (senderid, n)
Expand Down Expand Up @@ -27,8 +26,7 @@ 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 ThreadUtil.spawnTimeout (fn () => print "force terminating the server example after 1s";
exit (authority, 0))
1000
in exitAfterTimeout
authority 1000 0 "force terminating the server example after 1s"
end

4 changes: 2 additions & 2 deletions examples/fromuserguide/ifc_type_labels.trp
Original file line number Diff line number Diff line change
Expand Up @@ -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 _ = printL a
val _ = printWithLabels a
val _ = debugpc()
val w = a + x
val _ = printL w
val _ = printWithLabels w
in debugpc()
end

110 changes: 0 additions & 110 deletions lib/DeclassifyUtil.trp

This file was deleted.

12 changes: 6 additions & 6 deletions lib/Hash.trp
Original file line number Diff line number Diff line change
Expand Up @@ -10,15 +10,15 @@ let
*)
fun hashString s =
(* String hash with fast paths for small strings *)
let val len = String.size s
val radix = 127
val codeAt = String.sub' s
let val len = strlen s
val radix = 127
fun charCodeAt i = String.subCode (s,i)
in case len of 0 => 0
| 1 => codeAt 0
| 2 => (radix * codeAt 0 + codeAt 1) andb Number.maxInt32
| 1 => charCodeAt 0
| 2 => (radix * charCodeAt 0 + charCodeAt 1) andb Number.maxInt32
| _ => let fun go idx acc =
if len <= idx then acc
else go (idx + 1) ((acc * radix + codeAt idx) andb Number.maxInt32)
else go (idx + 1) ((acc * radix + charCodeAt idx) andb Number.maxInt32)
in go 0 0
end
end
Expand Down
10 changes: 3 additions & 7 deletions lib/List.trp
Original file line number Diff line number Diff line change
Expand Up @@ -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 mapi_aux j [] = []
| mapi_aux j x::xs = (f (j,x)) :: (mapi_aux (j+1) xs)
in mapi_aux 0 list
let fun mapj j [] = []
| mapj j x::xs = (f (j,x)) :: (mapj (j+1) xs)
in mapj 0 list
end

(* TODO: revMap *)
Expand All @@ -83,9 +83,6 @@ 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. *)
Expand Down Expand Up @@ -186,7 +183,6 @@ let (* -- List Access -- *)
map,
mapi,
foldl,
foldl1,
filter,
filteri,
partition,
Expand Down
Loading
Loading