diff --git a/.gitignore b/.gitignore index 6782ebc900b..4bf016557dd 100644 --- a/.gitignore +++ b/.gitignore @@ -2,8 +2,6 @@ .dvm /result* -nix/dev-in-nix - **/*~ **/_build **/_output diff --git a/Jenkinsfile b/Jenkinsfile deleted file mode 100644 index da8573475b7..00000000000 --- a/Jenkinsfile +++ /dev/null @@ -1,35 +0,0 @@ -pipeline { - agent any - stages { - stage ('git submodule') { - steps { - sh 'git submodule update --init --recursive' - sh 'git clone --recursive git@github.com:dfinity-lab/dev nix/dev' - sh 'git -C nix/dev checkout e588f0efa687667076dfab52fddde6ff29e0d82c' - sh 'git -C nix/dev submodule update --init --recursive' - } - } - - stage('Build (native)') { - steps { - sh 'nix-build -A native --arg test-dvm true' - } - } - stage('Test (native)') { - steps { - sh 'nix-build -A native_test --arg test-dvm true' - } - } - stage('Build and test (js)') { - steps { - sh 'nix-build -A js' - } - } - } - // Workspace Cleanup plugin - post { - always { - cleanWs() - } - } -} diff --git a/README.md b/README.md index 7ef013c7ad6..7bf10ac6076 100644 --- a/README.md +++ b/README.md @@ -13,21 +13,6 @@ To install the `asc` binary into your nix environment, use $ nix-env -i -f . -A native ``` -## Setup of `dev` - -Until we join the monorepo, we need a checkout the `dev` repository in -`nix/dev`; see the `Jenkinsfile` the precise revision to use. - -For a fresh checkout, run -``` -git clone --recursive git@github.com:dfinity-lab/dev nix/dev -git -C nix/dev checkout 2bc6…see…Jenkinsfile…fecd -git -C nix/dev submodule update --init --recursive -``` - -To update, just run the last two commands again. - - ## Development using Nix This is the command that should always pass on master is the following, which builds everything: @@ -65,7 +50,7 @@ installing all required tools without nix is out of scope). ``` opam install num vlq yojson bisect_ppx bisect_ppx-ocamlbuild menhir ``` - * Install the `wasm` package. We use a newer version than is on opam, and a + * Install the `wasm` Ocaml package. We use a newer version than is on opam, and a fork that supports the multi-value extension. See `nix/ocaml-wasm.nix` for the precise repository and version. You can use `nix` to fetch the correct source for you, and run the manual installation inside: @@ -73,19 +58,13 @@ installing all required tools without nix is out of scope). cd $(nix-build -Q -A wasm.src)/interpreter make install ``` - * Install the `wasm` tool, using + * Install various command line tools used by, in particuar, the test suite: ``` nix-env -i -f . -A wasm - ``` - * Install the `dvm` tool, using - ``` + nix-env -i -f . -A filecheck + nix-env -i -f . -A wabt nix-env -i -f . -A dvm ``` - or simply - ``` - ./update-dvm.sh - ``` - which also updates the `dev` checkout. ## Create a coverage report diff --git a/ci-pr.nix b/ci-pr.nix new file mode 100644 index 00000000000..7dcd26dad09 --- /dev/null +++ b/ci-pr.nix @@ -0,0 +1 @@ +import ./ci.nix diff --git a/ci.nix b/ci.nix index 7453ecd04e5..e861ec7c2d9 100644 --- a/ci.nix +++ b/ci.nix @@ -1,4 +1 @@ -# We need to set test-dvm to false because hydra has -# no access to the `dev` repo. This can go away once we join -# the monorepo. -import ./default.nix { test-dvm = false; } +import ./default.nix { } diff --git a/default.nix b/default.nix index f995e7d6c59..0b4cb92be09 100644 --- a/default.nix +++ b/default.nix @@ -5,11 +5,14 @@ let stdenv = nixpkgs.stdenv; in -let sourceByRegex = src: regexes: builtins.filterSource (path: type: +let sourceByRegex = src: regexes: builtins.path + { name = "actorscript"; + path = src; + filter = path: type: let relPath = nixpkgs.lib.removePrefix (toString src + "/") (toString path); in let match = builtins.match (nixpkgs.lib.strings.concatStringsSep "|" regexes); in - ( type == "directory" && match (relPath + "/") != null - || match relPath != null)) src; in + ( type == "directory" && match (relPath + "/") != null || match relPath != null); + }; in let ocaml_wasm = (import ./nix/ocaml-wasm.nix) { inherit (nixpkgs) stdenv fetchFromGitHub ocaml; @@ -30,12 +33,12 @@ let real-dvm = then if test-dvm then - if !builtins.pathExists ./nix/dev/default.nix - then - throw "\"test-dvm = true\" requires a checkout of dev in ./nix.\nSee Jenkinsfile for the required revision. " - else - # Pass devel = true until the dev test suite runs on MacOS again - ((import ./nix/dev) { devel = true; }).dvm + let dev = builtins.fetchGit { + url = "ssh://git@github.com/dfinity-lab/dev"; + ref = "master"; + rev = "55724569782676b1e08fdce265b7daddaeaec860"; + }; in + (import dev {}).dvm else null else dvm; in @@ -92,9 +95,10 @@ rec { "test/" "test/.*Makefile.*" "test/quick.mk" - "test/(run.*|fail)/" - "test/(run.*|fail)/.*.as" - "test/(run.*|fail)/ok/.*" + "test/(fail|run|run-dfinity)/" + "test/(fail|run|run-dfinity)/.*.as" + "test/(fail|run|run-dfinity)/ok/" + "test/(fail|run|run-dfinity)/ok/.*.ok" "test/.*.sh" "samples/" "samples/.*" @@ -111,6 +115,7 @@ rec { nixpkgs.wabt nixpkgs.bash nixpkgs.perl + filecheck ] ++ (if test-dvm then [ real-dvm ] else []); @@ -119,12 +124,13 @@ rec { asc --version make -C stdlib ASC=asc all make -C samples ASC=asc all - make -C test/run VERBOSE=1 ASC=asc all - make -C test/fail VERBOSE=1 ASC=asc all '' + - (if test-dvm then '' - make -C test/run-dfinity VERBOSE=1 ASC=asc all - '' else ""); + (if test-dvm + then '' + make -C test ASC=asc parallel + '' else '' + make -C test ASC=asc quick + ''); installPhase = '' mkdir -p $out @@ -149,9 +155,10 @@ rec { "test/" "test/.*Makefile.*" "test/quick.mk" - "test/(run.*|fail)/" - "test/(run.*|fail)/.*.as" - "test/(run.*|fail)/ok/.*" + "test/(fail|run|run-dfinity)/" + "test/(fail|run|run-dfinity)/.*.as" + "test/(fail|run|run-dfinity)/ok/" + "test/(fail|run|run-dfinity)/ok/.*.ok" "test/.*.sh" "samples/" "samples/.*" @@ -208,6 +215,9 @@ rec { wasm = ocaml_wasm; dvm = real-dvm; + filecheck = nixpkgs.linkFarm "FileCheck" + [ { name = "bin/FileCheck"; path = "${nixpkgs.llvm}/bin/FileCheck";} ]; + wabt = nixpkgs.wabt; all-systems-go = nixpkgs.releaseTools.aggregate { name = "all-systems-go"; diff --git a/design/TmpWireFormat.md b/design/TmpWireFormat.md new file mode 100644 index 00000000000..7138f18574e --- /dev/null +++ b/design/TmpWireFormat.md @@ -0,0 +1,102 @@ +Temporary Wire Format +===================== + +This document describes the serializaion format currently used by the +ActorScript runtime, i.e. a mapping from ActorScript types to DFINITY types (= +WebAssembly types + `databuf`, `elmembuf`, `funcref` and `actorref`), and a +mapping between the corresponding values. + +This is a scaffolding tool to prototype applications until we have decided upon +the actual IDL of the system, which will change all that is described here. + +It also does not support all features that we want to support eventually. In +particular, it does not support subtyping. + +Some types have a *specialized argument format* when used directly as a +function arguments, rather than nested inside a data structure. Other types use +the _general argument format (without references)_ or the _general argument +format (with references)_. + +Each argument of a function is serialized separately. If the function is +defined with a list of arguments, these all become arguments of the WebAssembly +function. See the [ActorScript guide](https://hydra.oregon.dfinity.build//job/dfinity-ci-build/actorscript.pr-252/users-guide/latest/download/1/guide/#function-types) for the precise rules for function arities. + + +Specialized argument format: `Word32` +------------------------------------- + +A message entry point with an argument of type `Word32` is directly represented +as a `I32`. + +Specialized argument format: `Text` +------------------------------------- + +A message entry point with an argument of type `Text` is represented as a `databuf` that contains the UTF8-encoded string. + +Note that there is no terminating `\0`, and the length is implicit as the +length of the `databuf`. + + +General argument format (without references) +-------------------------------------------- + +Arguments with a type that does not mention any reference types (no actors, no +shared functions), are represented as a `databuf`. This `databuf` is generated +by an in-order traversal of the data type. All numbers are fixed-width and in +little endian format. + + * A `Nat`, `Int` or `Word64` is represented by 8 bytes. + * A `Word32` is represented by 4 bytes. + * A `Word16` is represented by 2 bytes. + * A `Word8` is represented by 1 byte. + * A `Bool` is represented by 1 byte that is `0` for `false` and `1` for `true`. + * A `Text` is represented by 4 bytes indicating the length of the following + payload, followed by the payload as a utf8-encoded string (no trailing `\0`). + * An `Array` is represented by 4 bytes indicating the number of entries, + followed by the concatenation of the representation of these entries. + * An `Tuple` is represented the concatenation of the representation of its + entries. (No need for a length field, as it is statically determined.) + * An `Object` is represented the concatenation of the representation of its + fields, sorted by field name. (The field names are not serialized, as they + are statically known.) + * An `Option` is represented by a single byte `0` if it is `null`, or + otherwise by a single byte `1` followed by the representation of the value + * An empty tuple, the type `Null` and the type `Shared` are represented by + zero bytes. + + +*Example:* The ActorScript value +``` +(null, ?4, "!") : (?Text, ?Int, Text) +``` +is represented as +``` +00 01 04 00 00 00 00 00 00 00 01 21 +``` + +General argument format (with references) +----------------------------------------- + +Argument with a type that mentions reference types (actors or shared functions) +are represented as an `elembuf`: + + * the first entry is a `databuf` contains the data according to the format + above. + * all further entries are the references contained in the data. + +The above format is thus extended with the following case: + + * A reference (`actor`, `shared func`) is represented as a 32 bit number (4 + bytes). Thus number is an index into the surrounding `elembuf`. + + NB: The index is never never `0`, as the first entry in the `elembuf` is the + `databuf` with the actual data. + +*Example:* The ActorScript value +``` +(null, ?console) : (?actor {}, ?actor {log : Text -> () }) +``` +is represented as +``` +elembuf [databuf [00 01 01 00 00 00], console] +``` diff --git a/emacs/actorscript-mode.el b/emacs/actorscript-mode.el new file mode 100644 index 00000000000..39ded3f1ab3 --- /dev/null +++ b/emacs/actorscript-mode.el @@ -0,0 +1,151 @@ +;; ActorScript major mode for Emacs +;; initially based on Swift Mode. + +(setq actorscript-font-lock-keywords + (let* ( + ;; define several category of keywords + ;; these are each taken from either ActorScript's `lexer.mll' or `prelude.ml' files. + (x-types + '("Any" + "None" + "Shared" + "Null" + "Bool" + "Nat" + "Int" + "Word8" + "Word16" + "Word32" + "Word64" + "Float" + "Char" + "Text")) + (x-constants + '("null" + "true" + "false" + )) + (x-keywords + '("actor" + "and" + "async" + "assert" + "await" + "break" + "case" + "class" + "continue" + "label" + "else" + "for" + "func" + "if" + "in" + "module" + "new" + "not" + "object" + "or" + "let" + "loop" + "private" + "return" + "shared" + "switch" + "type" + "var" + "while" + "prim" + )) + ;; Braces introduce blocks; it's nice to make them stand + ;; out more than ordinary symbols + (x-braces + '( "{" + "}")) + (x-symbols + '( "(" + ")" + "[" + "]" + ;"{" + ;"}" + ";" + "," + ":" + "<:" + ;"\\." + ;"\\?" + "=" + "<" + ">" + ;"\\+" + "-" + ;"\\*" + "/" + "%" + "**" + "&" + "|" + ;"\\^" + "<<" + ">>" + "<<>" + "<>>" + "#" + "==" + "!=" + ">=" + "<=" + ":=" + "+=" + "-=" + "*=" + "/=" + "%=" + "**=" + "&=" + "|=" + "^=" + "<<=" + ">>=" + "<<>=" + "<>>=" + "#=" + )) + ;; xxx These still don't work: + (x-symbols-more + '( "\\." + "\\?" + "\\+" + "\\-" + "\\*" + "\\^" + )) + ;; generate regex string for each category of keywords + (x-types-regexp (regexp-opt x-types 'words)) + (x-constant-regexp (regexp-opt x-constants 'words)) + (x-keywords-regexp (regexp-opt x-keywords 'words)) + (x-braces-regexp (regexp-opt x-braces)) + (x-symbols-regexp (regexp-opt x-symbols)) + (x-symbols-more-regexp (regexp-opt x-symbols-more)) + ) + ;; + `( + (,x-types-regexp . font-lock-type-face) + (,x-constant-regexp . font-lock-constant-face) + (,x-keywords-regexp . font-lock-keyword-face) + (,x-braces-regexp . font-lock-keyword-face) + (,x-symbols-regexp . font-lock-builtin-face) + (,x-symbols-more-regexp . font-lock-builtin-face) + ))) + +(define-derived-mode actorscript-mode + swift-mode "ActorScript" + "Major mode for ActorScript, aka 'CanisterScript'." + (setq font-lock-defaults '((actorscript-font-lock-keywords))) + ) + +(add-to-list 'auto-mode-alist '("\\.as\\'" . actorscript-mode)) + +;; add the mode to the `features' list +(provide 'actorscript-mode) diff --git a/src/Makefile b/src/Makefile index bfcd4a47372..abec67d57db 100644 --- a/src/Makefile +++ b/src/Makefile @@ -21,10 +21,11 @@ OCAMLBUILD = ocamlbuild $(OCAML_FLAGS) \ $(OPAM_PACKAGES:%=-pkg %) \ -tags debug -.PHONY: all quick clean test test-quick +.PHONY: all parallel quick clean test test-parallel test-quick all: $(NAME) test +parallel: $(NAME) test-parallel quick: $(NAME) test-quick $(NAME): $(MAIN).$(BUILD) @@ -56,5 +57,8 @@ test: $(NAME) accept: $(NAME) $(MAKE) -C ../test ASC=$(ASC) accept +test-parallel: $(NAME) + $(MAKE) -C ../test ASC=$(ASC) parallel + test-quick: $(NAME) $(MAKE) -C ../test ASC=$(ASC) quick diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index badcddbb85d..3d5a48fb29a 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -25,10 +25,7 @@ let rec exp e = match e.it with | BlockE (ds, e1) -> "BlockE" $$ List.map dec ds @ [exp e1] | IfE (e1, e2, e3) -> "IfE" $$ [exp e1; exp e2; exp e3] | SwitchE (e, cs) -> "SwitchE" $$ [exp e] @ List.map case cs - | WhileE (e1, e2) -> "WhileE" $$ [exp e1; exp e2] - | LoopE (e1, None) -> "LoopE" $$ [exp e1] - | LoopE (e1, Some e2) -> "LoopE" $$ [exp e1; exp e2] - | ForE (p, e1, e2) -> "ForE" $$ [pat p; exp e1; exp e2] + | LoopE e1 -> "LoopE" $$ [exp e1] | LabelE (i, t, e) -> "LabelE" $$ [id i; typ t; exp e] | BreakE (i, e) -> "BreakE" $$ [id i; exp e] | RetE e -> "RetE" $$ [exp e] @@ -39,13 +36,18 @@ let rec exp e = match e.it with | PrimE p -> "PrimE" $$ [Atom p] | DeclareE (i, t, e1) -> "DeclareE" $$ [id i; exp e1] | DefineE (i, m, e1) -> "DefineE" $$ [id i; Arrange.mut m; exp e1] - | FuncE (x, cc, tp, p, t, e) -> - "FuncE" $$ [Atom x; call_conv cc] @ List.map typ_bind tp @ [pat p; typ t; exp e] + | FuncE (x, cc, tp, as_, t, e) -> + "FuncE" $$ [Atom x; call_conv cc] @ List.map typ_bind tp @ args as_@ [ typ t; exp e] | ActorE (i, ds, fs, t) -> "ActorE" $$ [id i] @ List.map dec ds @ fields fs @ [typ t] | NewObjE (s, fs, t) -> "NewObjE" $$ (Arrange.obj_sort' s :: fields fs @ [typ t]) and fields fs = List.fold_left (fun flds f -> (name f.it.name $$ [ id f.it.var ]):: flds) [] fs +and args = function + | [] -> [] + | as_ -> ["params" $$ List.map arg as_] + +and arg a = Atom a.it and pat p = match p.it with | WildP -> Atom "WildP" diff --git a/src/arrange_type.ml b/src/arrange_type.ml index f6a2762e7bd..c3ce43c35a0 100644 --- a/src/arrange_type.ml +++ b/src/arrange_type.ml @@ -44,6 +44,7 @@ let rec typ (t:Type.typ) = match t with | Func (s, c, tbs, at, rt) -> "Func" $$ [Atom (sharing s); Atom (control c)] @ List.map typ_bind tbs @ [ "" $$ (List.map typ at); "" $$ (List.map typ rt)] | Async t -> "Async" $$ [typ t] | Mut t -> "Mut" $$ [typ t] + | Serialized t -> "Serialized" $$ [typ t] | Shared -> Atom "Shared" | Any -> Atom "Any" | Non -> Atom "Non" diff --git a/src/async.ml b/src/async.ml index 0925f758615..b98c72d6632 100644 --- a/src/async.ml +++ b/src/async.ml @@ -43,12 +43,12 @@ module Transform() = struct let replyT as_seq typ = T.Func(T.Sharable, T.Returns, [], as_seq typ, []) - let fullfillT as_seq typ = T.Func(T.Local, T.Returns, [], as_seq typ, []) + let fulfillT as_seq typ = T.Func(T.Local, T.Returns, [], as_seq typ, []) let t_async as_seq t = T.Func (T.Local, T.Returns, [], [T.Func(T.Local, T.Returns, [],as_seq t,[])], []) - let new_async_ret as_seq t = [t_async as_seq t;fullfillT as_seq t] + let new_async_ret as_seq t = [t_async as_seq t;fulfillT as_seq t] let new_asyncT = T.Func ( @@ -63,22 +63,18 @@ module Transform() = struct idE ("@new_async"@@no_region) new_asyncT let new_async t1 = - let call_new_async = - callE new_asyncE - [t1] - (tupE []) - (T.seq (new_async_ret unary t1)) in - let async = fresh_var (typ (projE call_new_async 0)) in - let fullfill = fresh_var (typ (projE call_new_async 1)) in - (async,fullfill),call_new_async + let call_new_async = callE new_asyncE [t1] (tupE []) in + let async = fresh_var "async" (typ (projE call_new_async 0)) in + let fulfill = fresh_var "fulfill" (typ (projE call_new_async 1)) in + (async,fulfill),call_new_async let new_nary_async_reply t1 = - let (unary_async,unary_fullfill),call_new_async = new_async t1 in - let v' = fresh_var t1 in + let (unary_async,unary_fulfill),call_new_async = new_async t1 in + let v' = fresh_var "v" t1 in let ts1 = T.as_seq t1 in (* construct the n-ary async value, coercing the continuation, if necessary *) let nary_async = - let k' = fresh_var (contT t1) in + let k' = fresh_var "k" (contT t1) in match ts1 with | [t] -> unary_async @@ -86,28 +82,28 @@ module Transform() = struct let seq_of_v' = tupE (List.mapi (fun i _ -> projE v' i) ts) in k' --> (unary_async -*- ([v'] -->* (k' -*- seq_of_v'))) in - (* construct the n-ary reply message that sends a sequence of value to fullfill the async *) + (* construct the n-ary reply message that sends a sequence of value to fulfill the async *) let nary_reply = let vs,seq_of_vs = match ts1 with | [t] -> - let v = fresh_var t in + let v = fresh_var "rep" t in [v],v | ts -> - let vs = List.map fresh_var ts in + let vs = fresh_vars "rep" ts in vs, tupE vs in - vs -@>* (unary_fullfill -*- seq_of_vs) + vs -@>* (unary_fulfill -*- seq_of_vs) in - let async,reply = fresh_var (typ nary_async), fresh_var (typ nary_reply) in - (async,reply),blockE [letP (tupP [varP unary_async; varP unary_fullfill]) call_new_async] + let async,reply = fresh_var "async" (typ nary_async), fresh_var "fulfill" (typ nary_reply) in + (async,reply),blockE [letP (tupP [varP unary_async; varP unary_fulfill]) call_new_async] (tupE [nary_async; nary_reply]) let letEta e scope = match e.it with | VarE _ -> scope e (* pure, so reduce *) - | _ -> let f = fresh_var (typ e) in + | _ -> let f = fresh_var "x" (typ e) in letD f e :: (scope f) (* maybe impure; sequence *) let isAwaitableFunc exp = @@ -117,16 +113,6 @@ module Transform() = struct let extendTup ts t2 = ts @ [t2] - let extendTupP p1 p2 = - match p1.it with - | TupP ps -> - begin - match ps with - | [] -> p2, fun e -> blockE [letP p1 (tupE [])] e - | ps -> tupP (ps@[p2]), fun e -> e - end - | _ -> tupP [p1;p2], fun e -> e - (* Given sequence type ts, bind e of type (seq ts) to a sequence of expressions supplied to decs d_of_es, preserving effects of e when the sequence type is empty. @@ -137,11 +123,11 @@ module Transform() = struct | [] -> (expD e)::d_of_vs [] | [t] -> - let x = fresh_var t in + let x = fresh_var "x" t in let p = varP x in (letP p e)::d_of_vs [x] | ts -> - let xs = List.map fresh_var ts in + let xs = fresh_vars "x" ts in let p = tupP (List.map varP xs) in (letP p e)::d_of_vs (xs) @@ -176,6 +162,7 @@ module Transform() = struct | Obj (s, fs) -> Obj (s, List.map t_field fs) | Mut t -> Mut (t_typ t) | Shared -> Shared + | Serialized t -> Serialized (t_typ t) | Any -> Any | Non -> Non | Pre -> Pre @@ -259,10 +246,10 @@ module Transform() = struct []) -> (* TBR, why isn't this []? *) (t_typ (T.seq ts1),t_typ contT) | t -> assert false in - let k = fresh_var contT in - let v1 = fresh_var t1 in - let post = fresh_var (T.Func(T.Sharable,T.Returns,[],[],[])) in - let u = fresh_var T.unit in + let k = fresh_var "k" contT in + let v1 = fresh_var "v" t1 in + let post = fresh_var "post" (T.Func(T.Sharable,T.Returns,[],[],[])) in + let u = fresh_var "u" T.unit in let ((nary_async,nary_reply),def) = new_nary_async_reply t1 in (blockE [letP (tupP [varP nary_async; varP nary_reply]) def; funcD k v1 (nary_reply -*- v1); @@ -285,7 +272,7 @@ module Transform() = struct (blockE ( letP (tupP [varP nary_async; varP nary_reply]) def :: letEta exp1' (fun v1 -> letSeq ts1 exp2' (fun vs -> - [ expD (callE v1 typs (seqE (vs@[nary_reply])) T.unit) ] + [ expD (callE v1 typs (seqE (vs@[nary_reply]))) ] ) ) ) @@ -304,12 +291,8 @@ module Transform() = struct cases in SwitchE (t_exp exp1, cases') - | WhileE (exp1, exp2) -> - WhileE (t_exp exp1, t_exp exp2) - | LoopE (exp1, exp2_opt) -> - LoopE (t_exp exp1, Lib.Option.map t_exp exp2_opt) - | ForE (pat, exp1, exp2) -> - ForE (t_pat pat, t_exp exp1, t_exp exp2) + | LoopE exp1 -> + LoopE (t_exp exp1) | LabelE (id, typ, exp1) -> LabelE (id, t_typ typ, t_exp exp1) | BreakE (id, exp1) -> @@ -324,38 +307,37 @@ module Transform() = struct DeclareE (id, t_typ typ, t_exp exp1) | DefineE (id, mut ,exp1) -> DefineE (id, mut, t_exp exp1) - | FuncE (x, cc, typbinds, pat, typT, exp) -> + | FuncE (x, cc, typbinds, args, typT, exp) -> let s = cc.Value.sort in begin match s with | T.Local -> - FuncE (x, cc, t_typ_binds typbinds, t_pat pat, t_typ typT, t_exp exp) + FuncE (x, cc, t_typ_binds typbinds, t_args args, t_typ typT, t_exp exp) | T.Sharable -> begin match typ exp with | T.Tup [] -> - FuncE (x, cc, t_typ_binds typbinds, t_pat pat, t_typ typT, t_exp exp) + FuncE (x, cc, t_typ_binds typbinds, t_args args, t_typ typT, t_exp exp) | T.Async res_typ -> let cc' = Value.message_cc (cc.Value.n_args + 1) in let res_typ = t_typ res_typ in - let pat = t_pat pat in let reply_typ = replyT nary res_typ in let typ' = T.Tup [] in - let k = fresh_var reply_typ in - let pat',d = extendTupP pat (varP k) in + let k = fresh_var "k" reply_typ in + let args' = t_args args @ [ arg_of_exp k ] in let typbinds' = t_typ_binds typbinds in - let y = fresh_var res_typ in + let y = fresh_var "y" res_typ in let exp' = match exp.it with | CallE(_, async,_,cps) -> begin match async.it with - | PrimE("@async") -> d ((t_exp cps) -*- (y --> (k -*- y))) + | PrimE("@async") -> ((t_exp cps) -*- (y --> (k -*- y))) | _ -> assert false end | _ -> assert false in - FuncE (x, cc', typbinds', pat', typ', exp') + FuncE (x, cc', typbinds', args', typ', exp') | _ -> assert false end end @@ -379,6 +361,10 @@ module Transform() = struct and t_fields fs = List.map (fun f -> { f with note = t_typ f.note }) fs + and t_args as_ = List.map t_arg as_ + + and t_arg a = { a with note = t_typ a.note } + and t_pat pat = { pat with it = t_pat' pat.it; diff --git a/src/await.ml b/src/await.ml index b35c5014fc4..b7aa896ab58 100644 --- a/src/await.ml +++ b/src/await.ml @@ -24,7 +24,7 @@ let letcont k scope = | ContVar k' -> scope k' (* letcont eta-contraction *) | MetaCont (typ, cont) -> let k' = fresh_cont typ in - let v = fresh_var typ in + let v = fresh_var "v" typ in blockE [funcD k' v (cont v)] (* at this point, I'm really worried about variable capture *) (scope k') @@ -39,9 +39,8 @@ let ( -@- ) k exp2 = match exp2.it with | VarE _ -> k exp2 | _ -> - let u = fresh_var typ in - letE u exp2 - (k u) + let u = fresh_var "u" typ in + letE u exp2 (k u) (* Label environments *) @@ -97,12 +96,8 @@ and t_exp' context exp' = cases in SwitchE (t_exp context exp1, cases') - | WhileE (exp1, exp2) -> - WhileE (t_exp context exp1, t_exp context exp2) - | LoopE (exp1, exp2_opt) -> - LoopE (t_exp context exp1, Lib.Option.map (t_exp context) exp2_opt) - | ForE (pat, exp1, exp2) -> - ForE (pat, t_exp context exp1, t_exp context exp2) + | LoopE exp1 -> + LoopE (t_exp context exp1) | LabelE (id, _typ, exp1) -> let context' = LabelEnv.add id.it Label context in LabelE (id, _typ, t_exp context' exp1) @@ -165,7 +160,7 @@ and unary context k unE e1 = and binary context k binE e1 e2 = match eff e1, eff e2 with | T.Triv, T.Await -> - let v1 = fresh_var (typ e1) in (* TBR *) + let v1 = fresh_var "v" (typ e1) in (* TBR *) letE v1 (t_exp context e1) (c_exp context e2 (meta (typ e2) (fun v2 -> k -@- binE v1 v2))) | T.Await, T.Await -> @@ -189,7 +184,7 @@ and nary context k naryE es = | e1 :: es -> match eff e1 with | T.Triv -> - let v1 = fresh_var (typ e1) in + let v1 = fresh_var "v" (typ e1) in letE v1 (t_exp context e1) (nary_aux (v1 :: vs) es) | T.Await -> @@ -214,94 +209,17 @@ and c_if context k e1 e2 e3 = c_exp context e1 (meta (typ e1) (fun v1 -> ifE v1 e2 e3 answerT)) ) -and c_while context k e1 e2 = - let loop = fresh_var (contT T.unit) in - let v2 = fresh_var T.unit in - let e2 = match eff e2 with - | T.Triv -> loop -*- t_exp context e2 - | T.Await -> c_exp context e2 (ContVar loop) - in - match eff e1 with - | T.Triv -> - blockE [funcD loop v2 - (ifE (t_exp context e1) - e2 - (k -@- unitE) - answerT)] - (loop -*- unitE) - | T.Await -> - blockE [funcD loop v2 - (c_exp context e1 (meta (T.bool) - (fun v1 -> - ifE v1 - e2 - (k -@- unitE) - answerT)))] - (loop -*- unitE) - -and c_loop_none context k e1 = - let loop = fresh_var (contT T.unit) in +and c_loop context k e1 = + let loop = fresh_var "loop" (contT T.unit) in match eff e1 with | T.Triv -> assert false | T.Await -> - let v1 = fresh_var T.unit in + let v1 = fresh_var "v" T.unit in blockE [funcD loop v1 (c_exp context e1 (ContVar loop))] (loop -*- unitE) -and c_loop_some context k e1 e2 = - let loop = fresh_var (contT T.unit) in - let u = fresh_var T.unit in - let v1 = fresh_var T.unit in - let e2 = match eff e2 with - | T.Triv -> ifE (t_exp context e2) - (loop -*- unitE) - (k -@- unitE) - answerT - | T.Await -> - c_exp context e2 - (meta (typ e2) - (fun v2 -> ifE v2 - (loop -*- unitE) - (k -@- unitE) - answerT)) - in - match eff e1 with - | T.Triv -> - blockE [funcD loop u - (letE v1 (t_exp context e1) e2)] - (loop -*- unitE) - | T.Await -> - blockE [funcD loop u - (c_exp context e1 (meta (typ e1) (fun v1 -> e2)))] - (loop -*- unitE) - -and c_for context k pat e1 e2 = - let v1 = fresh_var (typ e1) in - let next_typ = (T.Func(T.Local, T.Returns, [], [], [T.Opt pat.note])) in - let dotnext v = dotE v nextN next_typ -*- unitE in - let loop = fresh_var (contT T.unit) in - let v2 = fresh_var T.unit in - let e2 = match eff e2 with - | T.Triv -> loop -*- t_exp context e2 - | T.Await -> c_exp context e2 (ContVar loop) in - let body v1 = - blockE - [funcD loop v2 - (switch_optE (dotnext v1) - (k -@- unitE) - pat e2 - T.unit)] - (loop -*- unitE) - in - match eff e1 with - | T.Triv -> - letE v1 (t_exp context e1) - (body v1) - | T.Await -> - c_exp context e1 (meta (typ e1) (fun v1 -> body v1)) - and c_exp context exp = c_exp' context exp @@ -365,14 +283,8 @@ and c_exp' context exp k = (meta (typ exp1) (fun v1 -> {exp with it = SwitchE(v1,cases')})) end) - | WhileE (exp1, exp2) -> - c_while context k exp1 exp2 - | LoopE (exp1, None) -> - c_loop_none context k exp1 - | LoopE (exp1, Some exp2) -> - c_loop_some context k exp1 exp2 - | ForE (pat, exp1, exp2) -> - c_for context k pat exp1 exp2 + | LoopE exp1 -> + c_loop context k exp1 | LabelE (id, _typ, exp1) -> letcont k (fun k -> @@ -507,7 +419,7 @@ and rename_pat' pat = | WildP | LitP _ -> (PatEnv.empty, pat.it) | VarP id -> - let v = fresh_var pat.note in + let v = fresh_var "v" pat.note in (PatEnv.singleton id.it v, VarP (id_of_exp v)) | TupP pats -> diff --git a/src/check_ir.ml b/src/check_ir.ml index 76512bfe4e3..2d26b1943df 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -70,6 +70,12 @@ let type_error at text : Diag.message = Diag.{ sev = Diag.Error; at; cat = "IR t let error env at fmt = Printf.ksprintf (fun s -> raise (CheckFailed (Diag.string_of_message (type_error at s)))) fmt +let check env at p fmt = + if p + then Printf.ikfprintf (fun () -> ()) () fmt + else error env at fmt + + let add_lab c x t = {c with labs = T.Env.add x t c.labs} @@ -98,25 +104,29 @@ let disjoint_union env at fmt env1 env2 = (* Types *) -let check_ids env ids = ignore - (List.fold_left - (fun dom id -> - if List.mem id dom - then error env no_region "duplicate field name %s in object type" id - else id::dom +let check_ids env ids = ignore ( + List.fold_left (fun dom id -> + check env no_region (not (List.mem id dom)) + "duplicate field name %s in object type" id; + id::dom ) [] ids ) -let check env at p = - if p then ignore - else error env at - let check_sub env at t1 t2 = - if T.sub t1 t2 - then () - else error env at "subtype violation:\n %s\n %s\n" + check env at (T.sub t1 t2) "subtype violation:\n %s\n %s\n" (T.string_of_typ_expand t1) (T.string_of_typ_expand t2) +let check_shared env at t = + if env.flavor.Ir.serialized + then check env at (T.is_serialized t) + "message argument is not serialized:\n %s" (T.string_of_typ_expand t) + else check env at (T.sub t T.Shared) + "message argument is not sharable:\n %s" (T.string_of_typ_expand t) + +let check_concrete env at t = + check env at (T.is_concrete t) + "message argument is not concrete:\n %s" (T.string_of_typ_expand t) + let rec check_typ env typ : unit = match typ with | T.Pre -> @@ -124,8 +134,7 @@ let rec check_typ env typ : unit = | T.Var (s, i) -> error env no_region "free type variable %s, index %i" s i | T.Con (c, typs) -> - if not (T.ConSet.mem c env.cons) then - error env no_region "free type constructor %s" (Con.name c); + check env no_region (T.ConSet.mem c env.cons) "free type constructor %s" (Con.name c); (match Con.kind c with | T.Def (tbs, t) | T.Abs (tbs, t) -> check_typ_bounds env tbs typs no_region ) @@ -154,8 +163,7 @@ let rec check_typ env typ : unit = (T.string_of_typ_expand t2) end; if sort = T.Sharable then begin - let t1 = T.seq ts1 in - check_sub env' no_region t1 T.Shared; + List.iter (fun t -> check_shared env no_region t) ts1; match ts2 with | [] -> () | [T.Async t2] -> @@ -168,7 +176,7 @@ let rec check_typ env typ : unit = | T.Async typ -> check env no_region env.flavor.Ir.has_async_typ "async in non-async flavor"; let t' = T.promote typ in - check_sub env no_region t' T.Shared + check_shared env no_region t' | T.Obj (sort, fields) -> let rec sorted fields = match fields with @@ -182,6 +190,11 @@ let rec check_typ env typ : unit = check env no_region (sorted fields) "object type's fields are not sorted" | T.Mut typ -> check_typ env typ + | T.Serialized typ -> + check env no_region env.flavor.Ir.serialized + "Serialized in non-serialized flavor"; + check_typ env typ; + check_sub env no_region typ T.Shared and check_typ_field env s typ_field : unit = let T.{lab; typ} = typ_field in @@ -363,16 +376,22 @@ let rec check_exp env (exp:Ir.exp) : unit = check_exp env exp2; (* TODO: check call_conv (assuming there's something to check) *) let t1 = T.promote (typ exp1) in - let tbs, t2, t3 = - try T.as_func_sub (List.length insts) t1 with + let _, tbs, t2, t3 = + try T.as_func_sub call_conv.Value.sort (List.length insts) t1 with | Invalid_argument _ -> error env exp1.at "expected function type, but expression produces type\n %s" (T.string_of_typ_expand t1) in check_inst_bounds env tbs insts exp.at; check_exp env exp2; - typ exp2 <: T.open_ insts t2; - T.open_ insts t3 <: t; + let t_arg = T.open_ insts t2 in + let t_ret = T.open_ insts t3 in + if (call_conv.Value.sort = T.Sharable) then begin + check_concrete env exp.at t_arg; + check_concrete env exp.at t_ret; + end; + typ exp2 <: t_arg; + t_ret <: t; | BlockE (ds, exp1) -> let scope = gather_block_decs env ds in let env' = adjoin env scope in @@ -394,42 +413,10 @@ let rec check_exp env (exp:Ir.exp) : unit = warn env exp.at "the cases in this switch do not cover all possible values"; *) check_cases env t1 t cases; - | WhileE (exp1, exp2) -> - check_exp env exp1; - typ exp1 <: T.bool; - check_exp env exp2; - typ exp2 <: T.unit; - T.unit <: t; - | LoopE (exp1, expo) -> + | LoopE exp1 -> check_exp env exp1; typ exp1 <: T.unit; - begin match expo with - | Some exp2 -> - check_exp env exp2; - typ exp2 <: T.bool; - T.unit <: t; - | _ -> - T.Non <: t; (* vacuously true *) - end; - | ForE (pat, exp1, exp2) -> - begin - check_exp env exp1; - let t1 = T.promote (typ exp1) in - try - let _, tfs = T.as_obj_sub "next" t1 in - let t0 = T.lookup_field "next" tfs in - let t1, t2 = T.as_mono_func_sub t0 in - T.unit <: t1; - let t2' = T.as_opt_sub t2 in - let ve = check_pat_exhaustive env pat in - pat.note <: t2'; - check_exp (adjoin_vals env ve) exp2; - typ exp2 <: T.unit; - T.unit <: t - with Invalid_argument _ -> - error env exp1.at "expected iterable type, but expression has type\n %s" - (T.string_of_typ_expand t1) - end; + T.Non <: t (* vacuously true *) | LabelE (id, t0, exp1) -> assert (t0 <> T.Pre); check_typ env t0; @@ -502,26 +489,28 @@ let rec check_exp env (exp:Ir.exp) : unit = typ exp1 <: t0 end; T.unit <: t - | FuncE (x, cc, typ_binds, pat, ret_ty, exp) -> + | FuncE (x, cc, typ_binds, args, ret_ty, exp) -> let cs, tbs, ce = check_open_typ_binds env typ_binds in let env' = adjoin_cons env ce in - let ve = check_pat_exhaustive env' pat in + let ve = check_args env' args in check_typ env' ret_ty; check ((cc.Value.sort = T.Sharable && Type.is_async ret_ty) ==> isAsyncE exp) "shared function with async type has non-async body"; + if (cc.Value.sort = T.Sharable) then check_concrete env exp.at ret_ty; let env'' = {env' with labs = T.Env.empty; rets = Some ret_ty; async = false} in check_exp (adjoin_vals env'' ve) exp; check_sub env' exp.at (typ exp) ret_ty; (* Now construct the function type and compare with the annotation *) - let arg_ty = pat.note in - let ts1 = if cc.Value.n_args = 1 - then [arg_ty] - else T.as_seq arg_ty in + let ts1 = List.map (fun a -> a.note) args in let ts2 = if cc.Value.n_res = 1 then [ret_ty] else T.as_seq ret_ty in + if (cc.Value.sort = T.Sharable) then begin + List.iter (check_concrete env exp.at) ts1; + List.iter (check_concrete env exp.at) ts2; + end; let fun_ty = T.Func ( cc.Value.sort, cc.Value.control , tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2 @@ -552,8 +541,19 @@ and check_case env t_pat t {it = {pat; exp}; _} = let ve = check_pat env pat in check_sub env pat.at pat.note t_pat; check_exp (adjoin_vals env ve) exp; - if not (T.sub (typ exp) t) then - error env exp.at "bad case" + check env pat.at (T.sub (typ exp) t) "bad case" + +(* Arguments *) + +and check_args env args = + let rec go ve = function + | [] -> ve + | a::as_ -> + check env a.at (not (T.Env.mem a.it ve)) + "duplicate binding for %s in argument list" a.it; + check_typ env a.note; + go (T.Env.add a.it a.note ve) as_ + in go T.Env.empty args (* Patterns *) @@ -564,8 +564,8 @@ and gather_pat env ve0 pat : val_env = | LitP _ -> ve | VarP id -> - if T.Env.mem id.it ve0 then - error env pat.at "duplicate binding for %s in block" id.it; + check env id.at (not (T.Env.mem id.it ve0)) + "duplicate binding for %s in block" id.it; T.Env.add id.it pat.note ve (*TBR*) | TupP pats -> List.fold_left go ve pats diff --git a/src/compile.ml b/src/compile.ml index 57a218ba1b1..8047c06ac62 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -25,6 +25,13 @@ let (^^) = G.(^^) (* is this how we import a single operator from a module that (* WebAssembly pages are 64kb. *) let page_size = Int32.of_int (64*1024) +(* +Pointers are skewed (translated) -1 relative to the actual offset. +See documentation of module BitTagged for more detail. +*) +let ptr_skew = -1l +let ptr_unskew = 1l + (* Helper functions to produce annotated terms (Wasm.AST) *) let nr x = { Wasm.Source.it = x; Wasm.Source.at = Wasm.Source.no_region } (* Dito, for the Source AST *) @@ -50,6 +57,7 @@ module SR = struct type t = | Vanilla | UnboxedTuple of int + | UnboxedRefTuple of int | UnboxedInt64 | UnboxedWord32 | UnboxedReference @@ -125,6 +133,7 @@ type 'env varloc = and 'env deferred_loc = { materialize : 'env -> (SR.t * G.t) ; materialize_vanilla : 'env -> G.t + ; is_local : bool (* Only valid within the current function *) } module E = struct @@ -215,7 +224,7 @@ module E = struct | Local _ -> false | HeapInd _ -> false | Static _ -> true - | Deferred _ -> true + | Deferred d -> not d.is_local let mk_fun_env env n_param n_res = { env with n_param; @@ -265,8 +274,10 @@ module E = struct let add_local_deferred_vanilla (env : t) name materialize = let d = { materialize = (fun env -> (SR.Vanilla, materialize env)); - materialize_vanilla = (fun env -> materialize env) } in - { env with local_vars_env = NameEnv.add name (Deferred d) env.local_vars_env } + materialize_vanilla = materialize; + is_local = false + } in + add_local_deferred env name d let add_direct_local (env : t) name = let i = add_anon_local env I32Type in @@ -366,7 +377,7 @@ module E = struct let add_static_bytes (env : t) data : int32 = let ptr = reserve_static_memory env (Int32.of_int (String.length data)) in env.static_memory := !(env.static_memory) @ [ (ptr, data) ]; - ptr + Int32.(add ptr ptr_skew) (* Return a skewed pointer *) let get_end_of_static_memory env : int32 = env.static_memory_frozen := true; @@ -389,16 +400,23 @@ end let compile_unboxed_const i = G.i (Wasm.Ast.Const (nr (Wasm.Values.I32 i))) let compile_const_64 i = G.i (Wasm.Ast.Const (nr (Wasm.Values.I64 i))) let compile_unboxed_zero = compile_unboxed_const 0l -(*let compile_unboxed_one = compile_unboxed_const 1l LATER*) +let compile_unboxed_one = compile_unboxed_const 1l (* Some common arithmetic, used for pointer and index arithmetic *) let compile_op_const op i = compile_unboxed_const i ^^ G.i (Binary (Wasm.Values.I32 op)) let compile_add_const = compile_op_const I32Op.Add -let compile_sub_const = compile_op_const I32Op.Sub +let _compile_sub_const = compile_op_const I32Op.Sub let compile_mul_const = compile_op_const I32Op.Mul let compile_divU_const = compile_op_const I32Op.DivU +let compile_shrU_const = function + | 0l -> G.nop | n -> compile_op_const I32Op.ShrU n +let compile_shl_const = function + | 0l -> G.nop | n -> compile_op_const I32Op.Shl n +let compile_bitand_const = compile_op_const I32Op.And +let compile_bitor_const = function + | 0l -> G.nop | n -> compile_op_const I32Op.Or n (* Locals *) @@ -414,23 +432,24 @@ let new_local env name = let (set_i, get_i, _) = new_local_ env I32Type name in (set_i, get_i) -let _new_local64 env name = +let new_local64 env name = let (set_i, get_i, _) = new_local_ env I64Type name in (set_i, get_i) (* Some common code macros *) -(* expects a number on the stack. Iterates from zero t below that number *) +(* Iterates while cond is true. *) let compile_while cond body = G.loop_ (ValBlockType None) ( cond ^^ G.if_ (ValBlockType None) (body ^^ G.i (Br (nr 1l))) G.nop ) +(* Expects a number on the stack. Iterates from zero to below that number. *) let from_0_to_n env mk_body = let (set_n, get_n) = new_local env "n" in let (set_i, get_i) = new_local env "i" in set_n ^^ - compile_unboxed_const 0l ^^ + compile_unboxed_zero ^^ set_i ^^ compile_while @@ -448,12 +467,18 @@ let from_0_to_n env mk_body = (* Pointer reference and dereference *) -let load_ptr : G.t = +let load_unskewed_ptr : G.t = G.i (Load {ty = I32Type; align = 2; offset = 0l; sz = None}) -let store_ptr : G.t = +let store_unskewed_ptr : G.t = G.i (Store {ty = I32Type; align = 2; offset = 0l; sz = None}) +let load_ptr : G.t = + G.i (Load {ty = I32Type; align = 2; offset = ptr_unskew; sz = None}) + +let store_ptr : G.t = + G.i (Store {ty = I32Type; align = 2; offset = ptr_unskew; sz = None}) + module Func = struct (* This module contains basic bookkeeping functionality to define functions, in particular creating the environment, and finally adding it to the environment. @@ -478,7 +503,7 @@ module Func = struct G.i (Call (nr (E.built_in env name))) (* Shorthands for various arities *) - let share_code0 env name retty mk_body = + let _share_code0 env name retty mk_body = share_code env name [] retty (fun env -> mk_body env) let share_code1 env name p1 retty mk_body = share_code env name [p1] retty (fun env -> mk_body env @@ -512,16 +537,17 @@ module Heap = struct let word_size = 4l (* We keep track of the end of the used heap in this global, and bump it if - we allocate stuff. *) + we allocate stuff. This the actual memory offset, not-skewed yet *) let heap_global = 2l let get_heap_ptr = G.i (GlobalGet (nr heap_global)) let set_heap_ptr = G.i (GlobalSet (nr heap_global)) + let get_skewed_heap_ptr = get_heap_ptr ^^ compile_add_const ptr_skew - (* Page allocation. Ensures that the memory up to the heap pointer is allocated. *) + (* Page allocation. Ensures that the memory up to the given unskewed pointer is allocated. *) let grow_memory env = - Func.share_code0 env "grow_memory" [] (fun env -> + Func.share_code1 env "grow_memory" ("ptr", I32Type) [] (fun env get_ptr -> let (set_pages_needed, get_pages_needed) = new_local env "pages_needed" in - get_heap_ptr ^^ compile_divU_const page_size ^^ + get_ptr ^^ compile_divU_const page_size ^^ compile_add_const 1l ^^ G.i MemorySize ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ @@ -529,13 +555,13 @@ module Heap = struct (* Check that the new heap pointer is within the memory *) get_pages_needed ^^ - compile_unboxed_const 0l ^^ + compile_unboxed_zero ^^ G.i (Compare (Wasm.Values.I32 I32Op.GtU)) ^^ G.if_ (ValBlockType None) ( get_pages_needed ^^ G.i MemoryGrow ^^ (* Check result *) - compile_unboxed_const 0l ^^ + compile_unboxed_zero ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtS)) ^^ G.if_ (ValBlockType None) (G.i Unreachable) G.nop ) G.nop @@ -544,15 +570,17 @@ module Heap = struct (* Dynamic allocation *) let dyn_alloc_words env = Func.share_code1 env "alloc_words" ("n", I32Type) [I32Type] (fun env get_n -> - (* expect the size (in words), returns the pointer *) - get_heap_ptr ^^ + (* expects the size (in words), returns the pointer *) + + (* return the current pointer (skewed) *) + get_skewed_heap_ptr ^^ (* Update heap pointer *) get_heap_ptr ^^ get_n ^^ compile_mul_const word_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_heap_ptr ^^ - grow_memory env + get_heap_ptr ^^ grow_memory env ) let dyn_alloc_bytes env = @@ -565,28 +593,32 @@ module Heap = struct ) (* Static allocation (always words) - (uses dynamic allocation for smaller and more readable code *) + (uses dynamic allocation for smaller and more readable code) *) let alloc env (n : int32) : G.t = compile_unboxed_const n ^^ dyn_alloc_words env (* Heap objects *) - (* At this level of abstactions, heap objects are just flat arrays of words *) + (* At this level of abstraction, heap objects are just flat arrays of words *) let load_field (i : int32) : G.t = - G.i (Load {ty = I32Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + let offset = Int32.(add (mul word_size i) ptr_unskew) in + G.i (Load {ty = I32Type; align = 2; offset; sz = None}) let store_field (i : int32) : G.t = - G.i (Store {ty = I32Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + let offset = Int32.(add (mul word_size i) ptr_unskew) in + G.i (Store {ty = I32Type; align = 2; offset; sz = None}) - (* Although we occationally want to treat to of them as a 64 bit number *) + (* Although we occasionally want to treat two 32 bit fields as one 64 bit number *) let load_field64 (i : int32) : G.t = - G.i (Load {ty = I64Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + let offset = Int32.(add (mul word_size i) ptr_unskew) in + G.i (Load {ty = I64Type; align = 2; offset; sz = None}) let store_field64 (i : int32) : G.t = - G.i (Store {ty = I64Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + let offset = Int32.(add (mul word_size i) ptr_unskew) in + G.i (Store {ty = I64Type; align = 2; offset; sz = None}) (* Create a heap object with instructions that fill in each word *) let obj env element_instructions : G.t = @@ -605,6 +637,7 @@ module Heap = struct get_heap_obj (* Convenience functions related to memory *) + (* Copying bytes (works on unskewed memory addresses) *) let memcpy env = Func.share_code3 env "memcpy" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> get_n ^^ @@ -622,6 +655,25 @@ module Heap = struct ) ) + (* Copying words (works on skewed memory addresses) *) + let memcpy_words_skewed env = + Func.share_code3 env "memcpy_words_skewed" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> + get_n ^^ + from_0_to_n env (fun get_i -> + get_to ^^ + get_i ^^ compile_mul_const word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + + get_from ^^ + get_i ^^ compile_mul_const word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + load_ptr ^^ + + store_ptr + ) + ) + + end (* Heap *) module ElemHeap = struct @@ -660,7 +712,7 @@ module ElemHeap = struct compile_mul_const Heap.word_size ^^ compile_add_const ref_location ^^ get_ref ^^ - store_ptr ^^ + store_unskewed_ptr ^^ (* Bump counter *) get_ref_ctr ^^ @@ -674,7 +726,7 @@ module ElemHeap = struct get_ref_idx ^^ compile_mul_const Heap.word_size ^^ compile_add_const ref_location ^^ - load_ptr + load_unskewed_ptr ) end (* ElemHeap *) @@ -699,7 +751,7 @@ module ClosureTable = struct (* For reasons I do not recall we use the first word of the table as the counter, and not a global. *) - let get_counter = compile_unboxed_const loc ^^ load_ptr + let get_counter = compile_unboxed_const loc ^^ load_unskewed_ptr (* Assumes a reference on the stack, and replaces it with an index into the reference table *) @@ -715,13 +767,13 @@ module ClosureTable = struct compile_mul_const Heap.word_size ^^ compile_add_const loc ^^ get_ptr ^^ - store_ptr ^^ + store_unskewed_ptr ^^ (* Bump counter *) compile_unboxed_const loc ^^ get_counter ^^ compile_add_const 1l ^^ - store_ptr + store_unskewed_ptr ) (* Assumes a index into the table on the stack, and replaces it with a ptr to the closure *) @@ -730,72 +782,74 @@ module ClosureTable = struct get_closure_idx ^^ compile_mul_const Heap.word_size ^^ compile_add_const loc ^^ - load_ptr + load_unskewed_ptr ) end (* ClosureTable *) module Bool = struct (* Boolean literals are either 0 or 1 - The 1 is recognized as a unboxed scalar anyways, - while the 0 is special (see below). + Both are recognized as unboxed scalars anyways, This allows us to use the result of the WebAssembly comparison operators directly, and to use the booleans directly with WebAssembly’s If. *) let lit = function - | false -> compile_unboxed_const 0l - | true -> compile_unboxed_const 1l + | false -> compile_unboxed_zero + | true -> compile_unboxed_one end (* Bool *) module BitTagged = struct - (* This module takes care of pointer tagging: Pointer are always aligned, so they - have their LSB bit unset. We use that and store an unboxed scalar x - as (x << 1 | 1). - Special case: The zero pointer is considered a scalar. + let scalar_shift = 2l + + (* This module takes care of pointer tagging: + + A pointer to an object at offset `i` on the heap is represented as + `i-1`, so the low two bits of the pointer are always set. We call + `i-1` a *skewed* pointer, in a feeble attempt to avoid the term shifted, + which may sound like a logical shift. + + We use the constants ptr_skew and ptr_unskew to change a pointer as a + signpost where we switch between raw pointers to skewed ones. + + This means we can store a small unboxed scalar x as (x << 2), and still + tell it apart from a pointer. + + We actually use the *second* lowest bit to tell a pointer apart from a + scalar. + + It means that 0 and 1 are also recognized as non-pointers, and we can use + these for false and true, matching the result of WebAssembly’s comparison + operators. *) let if_unboxed env retty is1 is2 = Func.share_code1 env "is_unboxed" ("x", I32Type) [I32Type] (fun env get_x -> (* Get bit *) get_x ^^ - compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.And)) ^^ + compile_bitand_const 0x2l ^^ (* Check bit *) - compile_unboxed_const 1l ^^ - G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ - G.if_ (ValBlockType None) - (Bool.lit true ^^ G.i Return) G.nop ^^ - (* Also check if it is the null-pointer *) - get_x ^^ - compile_unboxed_const 0l ^^ - G.i (Compare (Wasm.Values.I32 I32Op.Eq)) + G.i (Test (Wasm.Values.I32 I32Op.Eqz)) ) ^^ G.if_ retty is1 is2 (* The untag_scalar and tag functions expect 64 bit numbers *) let untag_scalar env = - compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) ^^ + compile_shrU_const scalar_shift ^^ G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) let tag = G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ - compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ - compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Or)) + compile_unboxed_const scalar_shift ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) (* The untag_i32 and tag_i32 functions expect 32 bit numbers *) let untag_i32 env = - compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) + compile_shrU_const scalar_shift let tag_i32 = - compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ - compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Or)) + compile_unboxed_const scalar_shift ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) end (* BitTagged *) @@ -866,8 +920,27 @@ module Tagged = struct set_tag ^^ go cases - let branch env retty (cases : (tag * G.t) list) : G.t = - branch_default env retty (G.i Unreachable) cases + (* like branch_default but the tag is known statically *) + let branch env retty = function + | [] -> failwith "branch" + | [_, code] -> G.i Drop ^^ code + | (_, code) :: cases -> branch_default env retty code cases + + (* like branch_default but also pushes the scrutinee on the stack for the + * branch's consumption *) + let _branch_default_with env retty def cases = + let (set_o, get_o) = new_local env "o" in + let prep (t, code) = (t, get_o ^^ code) + in set_o ^^ get_o ^^ branch_default env retty def (List.map prep cases) + + (* like branch_default_with but the tag is known statically *) + let branch_with env retty = function + | [] -> failwith "branch_with" + | [_, code] -> code + | (_, code) :: cases -> + let (set_o, get_o) = new_local env "o" in + let prep (t, code) = (t, get_o ^^ code) + in set_o ^^ get_o ^^ branch_default env retty (get_o ^^ code) (List.map prep cases) let obj env tag element_instructions : G.t = Heap.obj env @@ @@ -886,7 +959,7 @@ module Var = struct let static_fun_pointer env fi = Tagged.obj env Tagged.Closure [ compile_unboxed_const fi; - compile_unboxed_const 0l (* number of parameters: none *) + compile_unboxed_zero (* number of parameters: none *) ] (* Local variables may in general be mutable (or at least late-defined). @@ -919,7 +992,7 @@ module Var = struct | Some (Deferred d) -> G.i Unreachable | None -> G.i Unreachable - (* Returns the payload (vanialla representation) *) + (* Returns the payload (vanilla representation) *) let get_val_vanilla env var = match E.lookup_var env var with | Some (Local i) -> G.i (LocalGet (nr i)) | Some (HeapInd (i, off)) -> G.i (LocalGet (nr i)) ^^ Heap.load_field off @@ -955,7 +1028,17 @@ module Var = struct | Some (Static i) -> ( compile_unboxed_zero, fun env1 -> (E.add_local_static env1 var i, G.i Drop)) | Some (Deferred d) -> - ( compile_unboxed_zero, fun env1 -> (E.add_local_deferred env1 var d, G.i Drop)) + if d.is_local + then + ( d.materialize_vanilla env, + fun env1 -> + let (env2, j) = E.add_direct_local env1 var in + let restore_code = G.i (LocalSet (nr j)) + in (env2, restore_code) + ) + else + ( compile_unboxed_zero, + fun env1 -> (E.add_local_deferred env1 var d, G.i Drop)) | None -> (G.i Unreachable, fun env1 -> (env1, G.i Unreachable)) (* Returns a pointer to a heap allocated box for this. @@ -971,12 +1054,12 @@ module Var = struct end (* Var *) module Opt = struct - (* The Option type. Not much intereting to see here *) + (* The Option type. Not much interesting to see here *) let payload_field = Tagged.header_size (* This needs to be disjoint from all pointers, i.e. tagged as a scalar. *) - let null = compile_unboxed_const 3l + let null = compile_unboxed_const 5l let inject env e = Tagged.obj env Tagged.Some [e] let project = Heap.load_field Tagged.header_size @@ -1165,6 +1248,11 @@ module BoxedInt = struct │ tag │ i64 │ └─────┴─────┴─────┘ + Note, that due to the equivalence of in-memory and on-stack + representations, the 64-bit word type is also represented in this + way. As we get proper bigints, the memory representations should + be disambiguated and stack representations adapted. (Renaming + those will point out where the backend needs adjustments.) *) let payload_field = Tagged.header_size @@ -1220,8 +1308,7 @@ module BoxedSmallWord = struct get_i ^^ compile_elem ^^ Heap.store_field payload_field ^^ get_i - let box env = Func.share_code env "box_i32" ["n", I32Type] [I32Type] (fun env -> - let get_n = G.i (LocalGet (nr 0l)) in + let box env = Func.share_code1 env "box_i32" ("n", I32Type) [I32Type] (fun env get_n -> get_n ^^ compile_unboxed_const (Int32.of_int (1 lsl 10)) ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ G.if_ (ValBlockType (Some I32Type)) @@ -1229,18 +1316,172 @@ module BoxedSmallWord = struct (compile_box env get_n) ) - let unbox env = Func.share_code env "unbox_i32" ["n", I32Type] [I32Type] (fun env -> - let get_n = G.i (LocalGet (nr 0l)) in + let unbox env = Func.share_code1 env "unbox_i32" ("n", I32Type) [I32Type] (fun env get_n -> get_n ^^ BitTagged.if_unboxed env (ValBlockType (Some I32Type)) ( get_n ^^ BitTagged.untag_i32 env) ( get_n ^^ Heap.load_field payload_field) ) - (*let lit env n = compile_unboxed_const n ^^ box env*) + let _lit env n = compile_unboxed_const n ^^ box env end (* BoxedSmallWord *) +module UnboxedSmallWord = struct + (* While smaller-than-32bit words are treated as i32 from the WebAssembly perspective, + there are certain differences that are type based. This module provides helpers to abstract + over those. *) + + let shift_of_type = function + | Type.Word8 -> 24l + | Type.Word16 -> 16l + | _ -> 0l + + let bitwidth_mask_of_type = function + | Type.Word8 -> 0b111l + | Type.Word16 -> 0b1111l + | p -> todo "bitwidth_mask_of_type" (Arrange_type.prim p) 0l + + let const_of_type ty n = Int32.(shift_left n (to_int (shift_of_type ty))) + + let padding_of_type ty = Int32.(sub (const_of_type ty 1l) one) + + let mask_of_type ty = Int32.lognot (padding_of_type ty) + + let name_of_type ty seed = match Arrange.prim ty with + | Wasm.Sexpr.Atom s -> seed ^ "<" ^ s ^ ">" + | wtf -> todo "name_of_type" wtf seed + + (* Makes sure that we only shift/rotate the maximum number of bits available in the word. *) + let clamp_shift_amount = function + | Type.Word32 -> G.nop + | ty -> compile_bitand_const (bitwidth_mask_of_type ty) + + let shift_leftWordNtoI32 b = + compile_unboxed_const b ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) + + (* Makes sure that the word payload (e.g. shift/rotate amount) is in the LSB bits of the word. *) + let lsb_adjust = function + | Type.Word32 -> G.nop + | ty -> compile_shrU_const (shift_of_type ty) + + (* Makes sure that the word payload (e.g. operation result) is in the MSB bits of the word. *) + let msb_adjust = function + | Type.Word32 -> G.nop + | ty -> shift_leftWordNtoI32 (shift_of_type ty) + + (* Makes sure that the word representation invariant is restored. *) + let sanitize_word_result = function + | Type.Word32 -> G.nop + | ty -> compile_bitand_const (mask_of_type ty) + + (* Sets the number (according to the type's word invariant) of LSBs. *) + let compile_word_padding = function + | Type.Word32 -> G.nop + | ty -> compile_bitor_const (padding_of_type ty) + + (* Kernel for counting leading zeros, according to the word invariant. *) + let clz_kernel ty = + compile_word_padding ty ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Clz)) ^^ + msb_adjust ty + + (* Kernel for counting trailing zeros, according to the word invariant. *) + let ctz_kernel ty = + compile_word_padding ty ^^ + compile_unboxed_const (shift_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Rotr)) ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) ^^ + msb_adjust ty + + (* Kernel for arithmetic (signed) shift, according to the word invariant. *) + let shrs_kernel ty = + lsb_adjust ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ + sanitize_word_result ty + + (* Kernel for testing a bit position, according to the word invariant. *) + let btst_kernel env ty = + let (set_b, get_b) = new_local env "b" + in lsb_adjust ty ^^ set_b ^^ lsb_adjust ty ^^ + compile_unboxed_one ^^ get_b ^^ clamp_shift_amount ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.And)) + + (* Code points occupy 21 bits, no alloc needed in vanilla SR. *) + let unbox_codepoint = compile_shrU_const 8l + let box_codepoint = compile_shl_const 8l + + (* Two utilities for dealing with utf-8 encoded bytes. *) + let compile_load_byte get_ptr offset = + get_ptr ^^ G.i (Load {ty = I32Type; align = 0; offset; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) + + let compile_6bit_mask = compile_bitand_const 0b00111111l + + (* consume from get_c and build result (get/set_res), inspired by + * https://rosettacode.org/wiki/UTF-8_encode_and_decode#C *) + + (* Examine the byte pointed to by get_ptr, and if needed, following + * bytes, building an unboxed Unicode code point in location + * get_res, and finally returning the number of bytes consumed on + * the stack. *) + let len_UTF8_head env get_ptr set_res get_res = + let (set_c, get_c) = new_local env "utf-8" in + let under thres = + get_c ^^ set_res ^^ + get_c ^^ compile_unboxed_const thres ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtU)) in + let load_follower offset = compile_load_byte get_ptr offset ^^ compile_6bit_mask + in compile_load_byte get_ptr 0l ^^ set_c ^^ + under 0x80l ^^ + G.if_ (ValBlockType (Some I32Type)) + compile_unboxed_one + (under 0xe0l ^^ + G.if_ (ValBlockType (Some I32Type)) + (get_res ^^ compile_bitand_const 0b00011111l ^^ + compile_shl_const 6l ^^ + load_follower 1l ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + set_res ^^ + compile_unboxed_const 2l) + (under 0xf0l ^^ + G.if_ (ValBlockType (Some I32Type)) + (get_res ^^ compile_bitand_const 0b00001111l ^^ + compile_shl_const 12l ^^ + load_follower 1l ^^ + compile_shl_const 6l ^^ + load_follower 2l ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + set_res ^^ + compile_unboxed_const 3l) + (get_res ^^ compile_bitand_const 0b00000111l ^^ + compile_shl_const 18l ^^ + load_follower 1l ^^ + compile_shl_const 12l ^^ + load_follower 2l ^^ + compile_shl_const 6l ^^ + load_follower 3l ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + set_res ^^ + compile_unboxed_const 4l))) + + (* The get_ptr argument moves a pointer to the payload of a Text onto the stack. + Then char_length_of_UTF8 decodes the first character of the string and puts + + - the length (in bytes) of the UTF-8 encoding of the first character and + - its assembled code point (boxed) + onto the stack. *) + let char_length_of_UTF8 env get_ptr = + let (set_res, get_res) = new_local env "res" + in len_UTF8_head env get_ptr set_res get_res ^^ + BoxedSmallWord.box env ^^ + get_res ^^ box_codepoint + +end (* UnboxedSmallWord *) + (* Primitive functions *) module Prim = struct open Wasm.Values @@ -1261,26 +1502,38 @@ module Prim = struct ) ( get_i ) - let prim_word32toNat env = + (* The Word8 and Word16 bits sit in the MSBs of the i32, in this manner + we can perform almost all operations, with the exception of + - Mul (needs shr of one operand) + - Shr (needs masking of result) + - Rot (needs duplication into LSBs, masking of amount and masking of result) + - ctz (needs shr of operand or sub from result) + + Both Word8/16 easily fit into the vanilla stackrep, so no boxing is necessary. + This MSB-stored schema is also essentially what the interpreter is using. + *) + let prim_word32toNat = G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) - let prim_maskedWord32toNat mask env = - compile_unboxed_const mask ^^ - G.i (Binary (I32 I32Op.And)) ^^ - prim_word32toNat env - let prim_by_shiftWord32toInt b env = - compile_unboxed_const b ^^ - G.i (Binary (I32 I32Op.Shl)) ^^ + let prim_shiftWordNtoUnsigned b = + compile_shrU_const b ^^ + prim_word32toNat + let prim_word32toInt = + G.i (Convert (Wasm.Values.I64 I64Op.ExtendSI32)) + let prim_shiftWordNtoSigned b = compile_unboxed_const b ^^ G.i (Binary (I32 I32Op.ShrS)) ^^ - prim_word32toNat env - let prim_intToWord32 env = + prim_word32toInt + let prim_intToWord32 = G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) - let prim_word32toInt env = - G.i (Convert (Wasm.Values.I64 I64Op.ExtendSI32)) - let prim_maskToWord32 mask env = - prim_intToWord32 env ^^ - compile_unboxed_const mask ^^ - G.i (Binary (I32 I32Op.And)) + let prim_shiftToWordN b = + prim_intToWord32 ^^ + UnboxedSmallWord.shift_leftWordNtoI32 b + let prim_hashInt env = + let (set_n, get_n) = new_local64 env "n" in + set_n ^^ + get_n ^^ get_n ^^ compile_const_64 32L ^^ G.i (Binary (Wasm.Values.I64 I64Op.ShrU)) ^^ + G.i (Binary (Wasm.Values.I64 I64Op.Xor)) ^^ + prim_intToWord32 end (* Prim *) module Object = struct @@ -1421,11 +1674,6 @@ module Object = struct idx env obj_type f ^^ load_ptr - let load_idx_immut env name = - compile_unboxed_const (hash_field_name name) ^^ - idx_hash env false ^^ - load_ptr - end (* Object *) module Text = struct @@ -1434,6 +1682,8 @@ module Text = struct ┌─────┬─────────┬──────────────────┐ │ tag │ n_bytes │ bytes (padded) … │ └─────┴─────────┴──────────────────┘ + + Note: The bytes are UTF-8 encoded code points from Unicode. *) let header_size = Int32.add Tagged.header_size 1l @@ -1459,6 +1709,23 @@ module Text = struct let ptr = E.add_static_bytes env data in compile_unboxed_const ptr + let alloc env = Func.share_code1 env "text_alloc" ("len", I32Type) [I32Type] (fun env get_len -> + let (set_x, get_x) = new_local env "x" in + compile_unboxed_const (Int32.mul Heap.word_size header_size) ^^ + get_len ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + Heap.dyn_alloc_bytes env ^^ + set_x ^^ + + get_x ^^ Tagged.store Tagged.Text ^^ + get_x ^^ get_len ^^ Heap.store_field len_field ^^ + get_x + ) + + let unskewed_payload_offset = Int32.(add ptr_unskew (mul Heap.word_size header_size)) + let payload_ptr_unskewed = + compile_add_const unskewed_payload_offset + (* String concatentation. Expects two strings on stack *) let concat env = Func.share_code2 env "concat" (("x", I32Type), ("y", I32Type)) [I32Type] (fun env get_x get_y -> let (set_z, get_z) = new_local env "z" in @@ -1469,46 +1736,22 @@ module Text = struct get_y ^^ Heap.load_field len_field ^^ set_len2 ^^ (* allocate memory *) - compile_unboxed_const (Int32.mul Heap.word_size header_size) ^^ get_len1 ^^ get_len2 ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - Heap.dyn_alloc_bytes env ^^ + alloc env ^^ set_z ^^ - (* Set tag *) - get_z ^^ Tagged.store Tagged.Text ^^ - - (* Set length *) - get_z ^^ - get_len1 ^^ - get_len2 ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - Heap.store_field len_field ^^ - (* Copy first string *) - get_x ^^ - compile_add_const (Int32.mul Heap.word_size header_size) ^^ - - get_z ^^ - compile_add_const (Int32.mul Heap.word_size header_size) ^^ - + get_x ^^ payload_ptr_unskewed ^^ + get_z ^^ payload_ptr_unskewed ^^ get_len1 ^^ - Heap.memcpy env ^^ (* Copy second string *) - get_y ^^ - compile_add_const (Int32.mul Heap.word_size header_size) ^^ - - get_z ^^ - compile_add_const (Int32.mul Heap.word_size header_size) ^^ - get_len1 ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - + get_y ^^ payload_ptr_unskewed ^^ + get_z ^^ payload_ptr_unskewed ^^ get_len1 ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ get_len2 ^^ - Heap.memcpy env ^^ (* Done *) @@ -1534,13 +1777,13 @@ module Text = struct get_len1 ^^ from_0_to_n env (fun get_i -> get_x ^^ - compile_add_const (Int32.mul Heap.word_size header_size) ^^ + payload_ptr_unskewed ^^ get_i ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ get_y ^^ - compile_add_const (Int32.mul Heap.word_size header_size) ^^ + payload_ptr_unskewed ^^ get_i ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ @@ -1551,6 +1794,152 @@ module Text = struct Bool.lit true ) + let prim_decodeUTF8 env = + Func.share_code1 env "decodeUTF8" ("string", I32Type) [I32Type; + I32Type] (fun env get_string -> + let (set_ptr, get_ptr) = new_local env "ptr" + in get_string ^^ payload_ptr_unskewed ^^ set_ptr ^^ + UnboxedSmallWord.char_length_of_UTF8 env get_ptr + ) + + let common_funcs env0 = + let next_fun () : E.func_with_names = Func.of_body env0 ["clos", I32Type] [I32Type] (fun env -> + let (set_n, get_n) = new_local env "n" in + let (set_char, get_char) = new_local env "char" in + let (set_ptr, get_ptr) = new_local env "ptr" in + (* Get pointer to counter from closure *) + Closure.get ^^ Closure.load_data 0l ^^ + (* Get current counter (boxed) *) + Var.load ^^ + + (* Get current counter (unboxed) *) + BoxedSmallWord.unbox env ^^ + set_n ^^ + + get_n ^^ + (* Get length *) + Closure.get ^^ Closure.load_data 1l ^^ Heap.load_field len_field ^^ + G.i (Compare (Wasm.Values.I32 I32Op.GeU)) ^^ + G.if_ (ValBlockType (Some I32Type)) + (* Then *) + Opt.null + (* Else *) + begin (* Return stuff *) + Opt.inject env ( + Closure.get ^^ Closure.load_data 0l ^^ + get_n ^^ + get_n ^^ + Closure.get ^^ Closure.load_data 1l ^^ payload_ptr_unskewed ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_ptr ^^ + UnboxedSmallWord.len_UTF8_head env get_ptr set_char get_char ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + (* Store advanced counter *) + BoxedSmallWord.box env ^^ + Var.store ^^ + get_char ^^ UnboxedSmallWord.box_codepoint) + end + ) in + + let get_text_object = Closure.get ^^ Closure.load_data 0l in + let mk_iterator next_funid = Func.of_body env0 ["clos", I32Type] [I32Type] (fun env -> + (* next function *) + let (set_ni, get_ni) = new_local env "next" in + Closure.fixed_closure env next_funid + [ Tagged.obj env Tagged.MutBox [ compile_unboxed_zero ] + ; get_text_object + ] ^^ + set_ni ^^ + + Object.lit_raw env + [ nr_ (Name "next"), fun _ -> get_ni ]) + in E.define_built_in env0 "text_chars_next" next_fun; + E.define_built_in env0 "text_chars" + (fun () -> mk_iterator (E.built_in env0 "text_chars_next")); + + E.define_built_in env0 "text_len" + (fun () -> Func.of_body env0 ["clos", I32Type] [I32Type] (fun env -> + let (set_max, get_max) = new_local env "max" in + let (set_n, get_n) = new_local env "n" in + let (set_char, get_char) = new_local env "char" in + let (set_ptr, get_ptr) = new_local env "ptr" in + let (set_len, get_len) = new_local env "len" + in compile_unboxed_zero ^^ set_n ^^ + compile_unboxed_zero ^^ set_len ^^ + get_text_object ^^ Heap.load_field len_field ^^ set_max ^^ + compile_while + (get_n ^^ get_max ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtU))) + begin + get_text_object ^^ payload_ptr_unskewed ^^ get_n ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_ptr ^^ + UnboxedSmallWord.len_UTF8_head env get_ptr set_char get_char ^^ + get_n ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_n ^^ + get_len ^^ compile_add_const 1l ^^ set_len + end ^^ + get_len ^^ + G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) ^^ + BoxedInt.box env)) + + let fake_object_idx_option env built_in_name = + let (set_text, get_text) = new_local env "text" in + set_text ^^ + Closure.fixed_closure env (E.built_in env built_in_name) [ get_text ] + + let fake_object_idx env = function + | "chars" -> Some (fake_object_idx_option env "text_chars") + | "len" -> Some (fake_object_idx_option env "text_len") + | _ -> None + + let prim_showChar env = + let (set_c, get_c) = new_local env "c" in + let (set_utf8, get_utf8) = new_local env "utf8" in + let storeLeader bitpat shift = + get_c ^^ compile_shrU_const shift ^^ compile_bitor_const bitpat ^^ + G.i (Store {ty = I32Type; align = 0; + offset = unskewed_payload_offset; + sz = Some Wasm.Memory.Pack8}) in + let storeFollower offset shift = + get_c ^^ compile_shrU_const shift ^^ UnboxedSmallWord.compile_6bit_mask ^^ + compile_bitor_const 0b10000000l ^^ + G.i (Store {ty = I32Type; align = 0; + offset = Int32.add offset unskewed_payload_offset; + sz = Some Wasm.Memory.Pack8}) in + let allocPayload n = compile_unboxed_const n ^^ alloc env ^^ set_utf8 ^^ get_utf8 in + UnboxedSmallWord.unbox_codepoint ^^ + set_c ^^ + get_c ^^ + compile_unboxed_const 0x80l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ + G.if_ (ValBlockType None) + (allocPayload 1l ^^ storeLeader 0b00000000l 0l) + begin + get_c ^^ + compile_unboxed_const 0x800l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ + G.if_ (ValBlockType None) + begin + allocPayload 2l ^^ storeFollower 1l 0l ^^ + get_utf8 ^^ storeLeader 0b11000000l 6l + end + begin + get_c ^^ + compile_unboxed_const 0x10000l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ + G.if_ (ValBlockType None) + begin + allocPayload 3l ^^ storeFollower 2l 0l ^^ + get_utf8 ^^ storeFollower 1l 6l ^^ + get_utf8 ^^ storeLeader 0b11100000l 12l + end + begin + allocPayload 4l ^^ storeFollower 3l 0l ^^ + get_utf8 ^^ storeFollower 2l 6l ^^ + get_utf8 ^^ storeFollower 1l 12l ^^ + get_utf8 ^^ storeLeader 0b11110000l 18l + end + end + end ^^ + get_utf8 + end (* String *) module Array = struct @@ -1574,8 +1963,7 @@ module Array = struct (* No need to check the lower bound, we interpret is as unsigned *) (* Check the upper bound *) get_idx ^^ - get_array ^^ - Heap.load_field len_field ^^ + get_array ^^ Heap.load_field len_field ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ @@ -1641,8 +2029,7 @@ module Array = struct (* Then *) Opt.null (* Else *) - ( (* Get point to counter from closure *) - Closure.get ^^ Closure.load_data 0l ^^ + ( Closure.get ^^ Closure.load_data 0l ^^ (* Store increased counter *) get_i ^^ compile_add_const 1l ^^ @@ -1692,9 +2079,9 @@ module Array = struct ] @ element_instructions) let fake_object_idx_option env built_in_name = - let (set_i, get_i) = new_local env "array" in - set_i ^^ - Closure.fixed_closure env (E.built_in env built_in_name) [ get_i ] + let (set_array, get_array) = new_local env "array" in + set_array ^^ + Closure.fixed_closure env (E.built_in env built_in_name) [ get_array ] let fake_object_idx env = function | "get" -> Some (fake_object_idx_option env "array_get") @@ -1704,15 +2091,10 @@ module Array = struct | "vals" -> Some (fake_object_idx_option env "array_vals") | _ -> None - (* The primitive operations *) - (* No need to wrap them in RTS functions: They occur only once, in the prelude. *) - let init env = + (* Does not initialize the fields! *) + let alloc env = let (set_len, get_len) = new_local env "len" in - let (set_x, get_x) = new_local env "x" in let (set_r, get_r) = new_local env "r" in - set_x ^^ - BoxedInt.unbox env ^^ - G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ set_len ^^ (* Allocate *) @@ -1728,6 +2110,24 @@ module Array = struct get_len ^^ Heap.store_field len_field ^^ + get_r + + (* The primitive operations *) + (* No need to wrap them in RTS functions: They occur only once, in the prelude. *) + let init env = + let (set_len, get_len) = new_local env "len" in + let (set_x, get_x) = new_local env "x" in + let (set_r, get_r) = new_local env "r" in + set_x ^^ + BoxedInt.unbox env ^^ + G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ + set_len ^^ + + (* Allocate *) + get_len ^^ + alloc env ^^ + set_r ^^ + (* Write fields *) get_len ^^ from_0_to_n env (fun get_i -> @@ -1750,17 +2150,9 @@ module Array = struct (* Allocate *) get_len ^^ - compile_add_const header_size ^^ - Heap.dyn_alloc_words env ^^ + alloc env ^^ set_r ^^ - (* Write header *) - get_r ^^ - Tagged.store Tagged.Array ^^ - get_r ^^ - get_len ^^ - Heap.store_field len_field ^^ - (* Write fields *) get_len ^^ from_0_to_n env (fun get_i -> @@ -1791,7 +2183,7 @@ module Tuple = struct (* We represent the boxed empty tuple as the unboxed scalar 0, i.e. simply as number (but really anything is fine, we never look at this) *) - let compile_unit = compile_unboxed_const 1l + let compile_unit = compile_unboxed_one (* Expects on the stack the pointer to the array. *) let load_n n = Heap.load_field (Int32.add Array.header_size n) @@ -1954,7 +2346,8 @@ module Dfinity = struct Func.share_code1 env "databuf_of_text" ("string", I32Type) [I32Type] (fun env get_string -> (* Calculate the offset *) get_string ^^ - compile_add_const (Int32.mul Heap.word_size Text.header_size) ^^ + compile_add_const Int32.(add (mul Heap.word_size Text.header_size) ptr_unskew) ^^ + (* Calculate the length *) get_string ^^ Heap.load_field (Text.len_field) ^^ @@ -1995,7 +2388,7 @@ module Dfinity = struct G.i Unreachable let default_exports env = - (* these export seems to be wanted by the hypervisor/v8 *) + (* these exports seem to be wanted by the hypervisor/v8 *) E.add_export env (nr { name = explode "mem"; edesc = nr (MemoryExport (nr 0l)) @@ -2078,7 +2471,7 @@ module OrthogonalPersistence = struct set_i ^^ get_i ^^ - compile_unboxed_const 0l ^^ + compile_unboxed_zero ^^ G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) (* First run, call the start function *) @@ -2089,7 +2482,7 @@ module OrthogonalPersistence = struct get_i ^^ compile_add_const ElemHeap.table_end ^^ Heap.set_heap_ptr ^^ - Heap.grow_memory env ^^ + Heap.get_heap_ptr ^^ Heap.grow_memory env ^^ (* Load memory *) compile_unboxed_const ElemHeap.table_end ^^ @@ -2132,252 +2525,43 @@ module OrthogonalPersistence = struct end (* OrthogonalPersistence *) -module Serialization = struct - (* - The serialization strategy is as follows: - * We remember the current heap pointer and reference table pointer - * We deeply and compactly copy the arguments into the space beyond the heap - pointer. - * Special handling for closures: These are turned into funcrefs. - * We traverse this space and make all pointers relative to the beginning of - the space. Same for indices into the reference table. - * We externalize all that new data space into a databuf, and add it to the - reference table - * We externalize all that new table space into a elembuf - * We reset the heap pointer and table pointer, to garbage collect the scratch space. - - TODO: Cycles are not detected yet. - - We separate code for copying and the code for pointer adjustment because - the latter can be used again in the deseriazliation code. - - The deserialization is analogous: - * We internalize the elembuf into the table, bumping the table reference - pointer. - * The last entry of the table is the dataref from above. Since we don't - need it after this, we decrement the table reference pointer by one. - * We internalize this databuf intot the heap space, bumping the heap - pointer. - * We traverse this space and adjust all pointers. - Same for indices into the reference table. - *) - - let serialize_go env = - Func.share_code1 env "serialize_go" ("x", I32Type) [I32Type] (fun env get_x -> - let (set_copy, get_copy) = new_local env "x" in - - Heap.get_heap_ptr ^^ - set_copy ^^ - - get_x ^^ - BitTagged.if_unboxed env (ValBlockType (Some I32Type)) - ( get_x ) - ( get_x ^^ Tagged.branch env (ValBlockType (Some I32Type)) - [ Tagged.Int, - get_x ^^ - Heap.alloc env 2l ^^ - compile_unboxed_const (Int32.mul 2l Heap.word_size) ^^ - Heap.memcpy env ^^ - get_copy - ; Tagged.Reference, - get_x ^^ - Heap.alloc env 2l ^^ - compile_unboxed_const (Int32.mul 2l Heap.word_size) ^^ - Heap.memcpy env ^^ - get_copy - ; Tagged.Some, - Opt.inject env ( - get_x ^^ Opt.project ^^ - G.i (Call (nr (E.built_in env "serialize_go"))) - ) - ; Tagged.ObjInd, - Tagged.obj env Tagged.ObjInd [ - get_x ^^ Heap.load_field 1l ^^ - G.i (Call (nr (E.built_in env "serialize_go"))) - ] - ; Tagged.Array, - begin - let (set_len, get_len) = new_local env "len" in - get_x ^^ - Heap.load_field Array.len_field ^^ - set_len ^^ - - get_len ^^ - compile_add_const Array.header_size ^^ - Heap.dyn_alloc_words env ^^ - G.i Drop ^^ - - (* Copy header *) - get_x ^^ - get_copy ^^ - compile_unboxed_const (Int32.mul Heap.word_size Array.header_size) ^^ - Heap.memcpy env ^^ - - (* Copy fields *) - get_len ^^ - from_0_to_n env (fun get_i -> - get_copy ^^ - get_i ^^ - Array.idx env ^^ - - get_x ^^ - get_i ^^ - Array.idx env ^^ - load_ptr ^^ - G.i (Call (nr (E.built_in env "serialize_go"))) ^^ - store_ptr - ) ^^ - get_copy - end - ; Tagged.Text, - begin - let (set_len, get_len) = new_local env "len" in - get_x ^^ - Heap.load_field Text.len_field ^^ - (* get length in words *) - compile_add_const 3l ^^ - compile_divU_const Heap.word_size ^^ - compile_add_const Text.header_size ^^ - set_len ^^ - - get_len ^^ - Heap.dyn_alloc_words env ^^ - G.i Drop ^^ - - (* Copy header and data *) - get_x ^^ - get_copy ^^ - get_len ^^ - compile_mul_const Heap.word_size ^^ - Heap.memcpy env ^^ - - get_copy - end - ; Tagged.Object, - begin - let (set_len, get_len) = new_local env "len" in - get_x ^^ - Heap.load_field Object.size_field ^^ - set_len ^^ - - get_len ^^ - compile_mul_const 2l ^^ - compile_add_const Object.header_size ^^ - Heap.dyn_alloc_words env ^^ - G.i Drop ^^ - - (* Copy header *) - get_x ^^ - get_copy ^^ - compile_unboxed_const (Int32.mul Heap.word_size Object.header_size) ^^ - Heap.memcpy env ^^ - - (* Copy fields *) - get_len ^^ - from_0_to_n env (fun get_i -> - (* Copy hash *) - get_i ^^ - compile_mul_const 2l ^^ - compile_add_const Object.header_size ^^ - compile_mul_const Heap.word_size ^^ - get_copy ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - - get_i ^^ - compile_mul_const 2l ^^ - compile_add_const Object.header_size ^^ - compile_mul_const Heap.word_size ^^ - get_x ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - - - load_ptr ^^ - store_ptr ^^ - - (* Copy data *) - - get_i ^^ - compile_mul_const 2l ^^ - compile_add_const Object.header_size ^^ - compile_mul_const Heap.word_size ^^ - get_copy ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - compile_add_const Heap.word_size ^^ - - get_i ^^ - compile_mul_const 2l ^^ - compile_add_const Object.header_size ^^ - compile_mul_const Heap.word_size ^^ - get_x ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - compile_add_const Heap.word_size ^^ - - load_ptr ^^ - G.i (Call (nr (E.built_in env "serialize_go"))) ^^ - store_ptr - ) ^^ - get_copy - end - ] - ) - ) - - let shift_pointer_at env = - Func.share_code2 env "shift_pointer_at" (("loc", I32Type), ("ptr_offset", I32Type)) [] (fun env get_loc get_ptr_offset -> - let (set_ptr, get_ptr) = new_local env "ptr" in - get_loc ^^ - load_ptr ^^ - set_ptr ^^ - get_ptr ^^ - BitTagged.if_unboxed env (ValBlockType None) - (* nothing to do *) - ( G.nop ) - ( get_loc ^^ - get_ptr ^^ - get_ptr_offset ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - store_ptr - ) - ) - - (* Returns the object size (in bytes) *) +module HeapTraversal = struct + (* Returns the object size (in words) *) let object_size env = Func.share_code1 env "object_size" ("x", I32Type) [I32Type] (fun env get_x -> get_x ^^ Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Int, - compile_unboxed_const (Int32.mul 3l Heap.word_size) + compile_unboxed_const 3l + ; Tagged.SmallWord, + compile_unboxed_const 2l ; Tagged.Reference, - compile_unboxed_const (Int32.mul 2l Heap.word_size) + compile_unboxed_const 2l ; Tagged.Some, - compile_unboxed_const (Int32.mul 2l Heap.word_size) + compile_unboxed_const 2l ; Tagged.ObjInd, - compile_unboxed_const (Int32.mul 2l Heap.word_size) + compile_unboxed_const 2l ; Tagged.MutBox, - compile_unboxed_const (Int32.mul 2l Heap.word_size) + compile_unboxed_const 2l ; Tagged.Array, get_x ^^ Heap.load_field Array.len_field ^^ - compile_add_const Array.header_size ^^ - compile_mul_const Heap.word_size + compile_add_const Array.header_size ; Tagged.Text, get_x ^^ Heap.load_field Text.len_field ^^ compile_add_const 3l ^^ compile_divU_const Heap.word_size ^^ - compile_add_const Text.header_size ^^ - compile_mul_const Heap.word_size + compile_add_const Text.header_size ; Tagged.Object, get_x ^^ Heap.load_field Object.size_field ^^ compile_mul_const 2l ^^ - compile_add_const Object.header_size ^^ - compile_mul_const Heap.word_size + compile_add_const Object.header_size ; Tagged.Closure, get_x ^^ Heap.load_field Closure.len_field ^^ - compile_add_const Closure.header_size ^^ - compile_mul_const Heap.word_size + compile_add_const Closure.header_size ] (* Indirections have unknown size. *) ) @@ -2393,7 +2577,7 @@ module Serialization = struct ) ( mk_code get_x ^^ get_x ^^ - get_x ^^ object_size env ^^ + get_x ^^ object_size env ^^ compile_mul_const Heap.word_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_x ) @@ -2460,241 +2644,577 @@ module Serialization = struct ) ] - let shift_pointers env = - Func.share_code3 env "shift_pointers" (("start", I32Type), ("to", I32Type), ("ptr_offset", I32Type)) [] (fun env get_start get_to get_ptr_offset -> - walk_heap_from_to env get_start get_to (fun get_x -> - for_each_pointer env get_x (fun get_ptr_loc -> - get_ptr_loc ^^ - get_ptr_offset ^^ - shift_pointer_at env +end (* HeapTraversal *) + +module Serialization = struct + (* + Also see (and update) `design/TmpWireFormat.md`, which documents the format + in a “user-facing” way. + + We have a specific serialization strategy for `Text`, `Word32` and + references for easier interop with the console and the nonce. This is a + stop-gap measure until we have nailed down IDL and Bidirectional Messaging. + + The general serialization strategy is as follows: + * We traverse the data to calculate the size needed for the data buffer and the + reference buffer. + * We remember the current heap pointer, and use the space after as scratch space. + * The scratch space is separated into two regions: + One for references, and one for raw data. + * We traverse the data, in a type-driven way, and copy it to the scratch space. + We thread through pointers to the current free space of the two scratch spaces. + This is type driven, and we use the `share_code` machinery and names that + properly encode the type to resolve loops in a convenient way. + * We externalize all that new data space into a databuf, and add this reference + to the reference space. + * We externalize the reference space into a elembuf + * We reset the heap pointer and table pointer, to garbage collect the scratch space. + + TODO: Cycles are not detected. + + The deserialization is analogous: + * We allocate some scratch space, and internalize the elembuf into it. + * We allocate some more scratch space, and internalize the databuf into it. + * We parse the data, in a type-driven way, using normal construction and + allocation. + * At the end, the scratch space is a hole in the heap, and will be reclaimed + by the next GC. + *) + + (* A type identifier *) + + (* + This needs to map types to some identifier with the following properties: + - Its domain are normalized types that do not mention any type parameters + - It needs to be injective wrt. type equality + - It needs to terminate, even for recursive types + - It may fail upon type parameters (i.e. no polymorphism) + We can use string_of_typ here for now, it seems. + *) + let typ_id : Type.typ -> string = Type.string_of_typ + + + + (* Checks whether the serialization of a given type could contain references *) + module TS = Set.Make (struct type t = Type.typ let compare = compare end) + let has_no_references : Type.typ -> bool = fun t -> + let open Type in + let seen = ref TS.empty in (* break the cycles *) + let rec go t = + TS.mem t !seen || + begin + seen := TS.add t !seen; + match t with + | Var _ -> assert false + | (Prim _ | Any | Non | Shared | Pre) -> true + | Con (c, ts) -> + begin match Con.kind c with + | Abs _ -> assert false + | Def (tbs,t) -> go (open_ ts t) (* TBR this may fail to terminate *) + end + | Array t -> go t + | Tup ts -> List.for_all go ts + | Func (Sharable, c, tbs, ts1, ts2) -> false + | Func (s, c, tbs, ts1, ts2) -> + let ts = open_binds tbs in + List.for_all go (List.map (open_ ts) ts1) && + List.for_all go (List.map (open_ ts) ts2) + | Opt t -> go t + | Async t -> go t + | Obj (Actor, fs) -> false + | Obj (s, fs) -> List.for_all (fun f -> go f.typ) fs + | Mut t -> go t + | Serialized t -> go t + end + in go t + + (* Returns data (in bytes) and reference buffer size (in entries) needed *) + let rec buffer_size env t = + let open Type in + let t = normalize t in + let name = "@buffer_size<" ^ typ_id t ^ ">" in + Func.share_code1 env name ("x", I32Type) [I32Type; I32Type] + (fun env get_x -> + + (* Some combinators for writing values *) + let (set_data_size, get_data_size) = new_local env "data_size" in + let (set_ref_size, get_ref_size) = new_local env "ref_size" in + compile_unboxed_const 0l ^^ set_data_size ^^ + compile_unboxed_const 0l ^^ set_ref_size ^^ + + let inc_data_size code = + get_data_size ^^ code ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + set_data_size + in + let inc_ref_size i = + get_ref_size ^^ compile_add_const i ^^ set_ref_size + in + + let size env t = + buffer_size env t ^^ + get_ref_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_ref_size ^^ + get_data_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_data_size + in + + (* Now the actual type-dependent code *) + begin match t with + | Prim (Nat|Int|Word64) -> inc_data_size (compile_unboxed_const 8l) (* 64 bit *) + | Prim Word8 -> inc_data_size (compile_unboxed_const 1l) + | Prim Word16 -> inc_data_size (compile_unboxed_const 2l) + | Prim Word32 -> inc_data_size (compile_unboxed_const 4l) + | Prim Bool -> inc_data_size (compile_unboxed_const 1l) + | Tup ts -> + G.concat_mapi (fun i t -> + get_x ^^ Tuple.load_n (Int32.of_int i) ^^ + size env t + ) ts + | Obj (Object Sharable, fs) -> + (* Disregarding all subtyping, and assuming sorted fields, we can just + treat this like a tuple *) + G.concat_mapi (fun i f -> + let n = { it = Name f.Type.lab; at = no_region; note = () } in + get_x ^^ Object.load_idx env t n ^^ + size env f.typ + ) fs + | Array t -> + inc_data_size (compile_unboxed_const Heap.word_size) ^^ (* 32 bit length field *) + get_x ^^ + Heap.load_field Array.len_field ^^ + from_0_to_n env (fun get_i -> + get_x ^^ get_i ^^ Array.idx env ^^ load_ptr ^^ + size env t ) - ) + | Prim Text -> + inc_data_size ( + compile_unboxed_const Heap.word_size ^^ (* 32 bit length field *) + get_x ^^ Heap.load_field Text.len_field ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) + ) + | (Prim Null | Shared) -> G.nop + | Opt t -> + inc_data_size (compile_unboxed_const 1l) ^^ (* one byte tag *) + get_x ^^ + Opt.null ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType None) G.nop + ( get_x ^^ Opt.project ^^ size env t) + | (Func _ | Obj (Actor, _)) -> + inc_data_size (compile_unboxed_const Heap.word_size) ^^ + inc_ref_size 1l + | _ -> todo "buffer_size" (Arrange_ir.typ t) G.nop + end ^^ + get_data_size ^^ + get_ref_size ) - let extract_references env = - Func.share_code3 env "extract_references" (("start", I32Type), ("to", I32Type), ("tbl_area", I32Type)) [I32Type] (fun env get_start get_to get_tbl_area -> - let (set_i, get_i) = new_local env "i" in + (* Copies x to the data_buffer, storing references after ref_count entries in ref_base *) + let rec serialize_go env t = + let open Type in + let t = normalize t in + let name = "@serialize_go<" ^ typ_id t ^ ">" in + Func.share_code4 env name (("x", I32Type), ("data_buffer", I32Type), ("ref_base", I32Type), ("ref_count" , I32Type)) [I32Type; I32Type] + (fun env get_x get_data_buf get_ref_base get_ref_count -> + let set_data_buf = G.i (LocalSet (nr 1l)) in + let set_ref_count = G.i (LocalSet (nr 3l)) in + + (* Some combinators for writing values *) + + let advance_data_buf = + get_data_buf ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_data_buf in + let allocate_ref = + get_ref_count ^^ + get_ref_count ^^ compile_add_const 1l ^^ set_ref_count in + + let write_word code = + get_data_buf ^^ code ^^ store_unskewed_ptr ^^ + compile_unboxed_const Heap.word_size ^^ advance_data_buf + in - compile_unboxed_const 0l ^^ set_i ^^ + let write_byte code = + get_data_buf ^^ code ^^ + G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack8}) ^^ + compile_unboxed_const 1l ^^ advance_data_buf + in - walk_heap_from_to env get_start get_to (fun get_x -> - get_x ^^ - Tagged.branch_default env (ValBlockType None) G.nop - [ Tagged.Reference, - (* Adjust reference *) - get_tbl_area ^^ - get_i ^^ compile_mul_const Heap.word_size ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - get_x ^^ - Dfinity.unbox_reference env ^^ - store_ptr ^^ - - get_x ^^ - get_i ^^ - Heap.store_field 1l ^^ + let write env t = + get_data_buf ^^ + get_ref_base ^^ + get_ref_count ^^ + serialize_go env t ^^ + set_ref_count ^^ + set_data_buf + in - get_i ^^ - compile_add_const 1l ^^ - set_i - ] - ) ^^ - get_i + (* Now the actual serialization *) + + begin match t with + | Prim (Nat | Int | Word64) -> + get_data_buf ^^ + get_x ^^ BoxedInt.unbox env ^^ + G.i (Store {ty = I64Type; align = 0; offset = 0l; sz = None}) ^^ + compile_unboxed_const 8l ^^ advance_data_buf + | Prim Word32 -> + get_data_buf ^^ + get_x ^^ BoxedSmallWord.unbox env ^^ + G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = None}) ^^ + compile_unboxed_const 4l ^^ advance_data_buf + | Prim Word16 -> + get_data_buf ^^ + get_x ^^ UnboxedSmallWord.lsb_adjust Word16 ^^ + G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack16}) ^^ + compile_unboxed_const 2l ^^ advance_data_buf + | Prim Word8 -> + get_data_buf ^^ + get_x ^^ UnboxedSmallWord.lsb_adjust Word16 ^^ + G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack8}) ^^ + compile_unboxed_const 1l ^^ advance_data_buf + | Prim Bool -> + get_data_buf ^^ + get_x ^^ + G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack8}) ^^ + compile_unboxed_const 1l ^^ advance_data_buf + | Tup ts -> + G.concat_mapi (fun i t -> + get_x ^^ Tuple.load_n (Int32.of_int i) ^^ + write env t + ) ts + | Obj (Object Sharable, fs) -> + (* Disregarding all subtyping, and assuming sorted fields, we can just + treat this like a tuple *) + G.concat_mapi (fun i f -> + let n = { it = Name f.Type.lab; at = no_region; note = () } in + get_x ^^ Object.load_idx env t n ^^ + write env f.typ + ) fs + | Array t -> + write_word (get_x ^^ Heap.load_field Array.len_field) ^^ + get_x ^^ Heap.load_field Array.len_field ^^ + from_0_to_n env (fun get_i -> + get_x ^^ get_i ^^ Array.idx env ^^ load_ptr ^^ + write env t + ) + | (Prim Null | Shared) -> G.nop + | Opt t -> + get_x ^^ + Opt.null ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType None) + ( write_byte (compile_unboxed_const 0l) ) + ( write_byte (compile_unboxed_const 1l) ^^ get_x ^^ Opt.project ^^ write env t ) + | Prim Text -> + let (set_len, get_len) = new_local env "len" in + get_x ^^ Heap.load_field Text.len_field ^^ + compile_add_const Heap.word_size ^^ + set_len ^^ + get_x ^^ compile_add_const (Int32.mul Tagged.header_size Heap.word_size) ^^ + compile_add_const ptr_unskew ^^ + get_data_buf ^^ + get_len ^^ + Heap.memcpy env ^^ + get_len ^^ advance_data_buf + | (Func _ | Obj (Actor, _)) -> + get_ref_base ^^ + get_ref_count ^^ compile_mul_const Heap.word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + get_x ^^ Dfinity.unbox_reference env ^^ + store_unskewed_ptr ^^ + write_word allocate_ref + | _ -> todo "serialize" (Arrange_ir.typ t) G.nop + end ^^ + get_data_buf ^^ + get_ref_count ) - let intract_references env = - Func.share_code3 env "intract_references" (("start", I32Type), ("to", I32Type), ("tbl_area", I32Type)) [] (fun env get_start get_to get_tbl_area -> - walk_heap_from_to env get_start get_to (fun get_x -> - get_x ^^ - Tagged.branch_default env (ValBlockType None) G.nop - [ Tagged.Reference, - get_x ^^ - (* Adjust reference *) - get_x ^^ - Heap.load_field 1l ^^ - compile_mul_const Heap.word_size ^^ - get_tbl_area ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - load_ptr ^^ - ElemHeap.remember_reference env ^^ - Heap.store_field 1l - ] - ) + let rec deserialize_go env t = + let open Type in + let t = normalize t in + let name = "@deserialize_go<" ^ typ_id t ^ ">" in + Func.share_code2 env name (("data_buffer", I32Type), ("ref_base", I32Type)) [I32Type; I32Type] + (fun env get_data_buf get_ref_base -> + let set_data_buf = G.i (LocalSet (nr 0l)) in + + (* Some combinators for reading values *) + let advance_data_buf = + get_data_buf ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + set_data_buf + in + + let read_byte = + get_data_buf ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ + compile_unboxed_const 1l ^^ advance_data_buf + in + + let read_word = + get_data_buf ^^ load_unskewed_ptr ^^ + compile_unboxed_const Heap.word_size ^^ advance_data_buf + in + + let read env t = + get_data_buf ^^ + get_ref_base ^^ + deserialize_go env t ^^ + set_data_buf + in + + (* Now the actual deserialization *) + begin match t with + | Prim (Nat | Int | Word64) -> + get_data_buf ^^ + G.i (Load {ty = I64Type; align = 2; offset = 0l; sz = None}) ^^ + BoxedInt.box env ^^ + compile_unboxed_const 8l ^^ advance_data_buf (* 64 bit *) + | Prim Word32 -> + get_data_buf ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = None}) ^^ + BoxedSmallWord.box env ^^ + compile_unboxed_const 4l ^^ advance_data_buf + | Prim Word16 -> + get_data_buf ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack16, Wasm.Memory.ZX)}) ^^ + UnboxedSmallWord.msb_adjust Word16 ^^ + compile_unboxed_const 2l ^^ advance_data_buf + | Prim Word8 -> + get_data_buf ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ + UnboxedSmallWord.msb_adjust Word8 ^^ + compile_unboxed_const 1l ^^ advance_data_buf + | Prim Bool -> + get_data_buf ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ + compile_unboxed_const 1l ^^ advance_data_buf + | Tup ts -> + G.concat_map (fun t -> read env t) ts ^^ + Tuple.from_stack env (List.length ts) + | Obj (Object Sharable, fs) -> + (* Disregarding all subtyping, and assuming sorted fields, we can just + treat this like a tuple *) + Object.lit_raw env (List.map (fun f -> + let n = { it = Name f.Type.lab; at = no_region; note = () } in + n, fun env -> read env f.typ + ) fs) + | Array t -> + let (set_len, get_len) = new_local env "len" in + let (set_x, get_x) = new_local env "x" in + + read_word ^^ set_len ^^ + get_len ^^ Array.alloc env ^^ set_x ^^ + get_len ^^ from_0_to_n env (fun get_i -> + get_x ^^ get_i ^^ Array.idx env ^^ + read env t ^^ store_ptr + ) ^^ + get_x + | (Prim Null | Shared) -> Opt.null + | Opt t -> + read_byte ^^ + compile_unboxed_const 0l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType (Some I32Type)) + ( Opt.null ) + ( Opt.inject env (read env t) ) + | Prim Text -> + let (set_len, get_len) = new_local env "len" in + let (set_x, get_x) = new_local env "x" in + read_word ^^ set_len ^^ + + get_len ^^ Text.alloc env ^^ set_x ^^ + + get_data_buf ^^ + get_x ^^ Text.payload_ptr_unskewed ^^ + get_len ^^ + Heap.memcpy env ^^ + + get_len ^^ advance_data_buf ^^ + + get_x + | (Func _ | Obj (Actor, _)) -> + get_ref_base ^^ + read_word ^^ compile_mul_const Heap.word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + load_unskewed_ptr ^^ + Dfinity.box_reference env + | _ -> todo "deserialize" (Arrange_ir.typ t) (G.i Unreachable) + end ^^ + get_data_buf ) - let serialize env = + let serialize env t = + let name = "@serialize<" ^ typ_id t ^ ">" in if E.mode env <> DfinityMode - then Func.share_code1 env "serialize" ("x", I32Type) [I32Type] (fun env _ -> G.i Unreachable) - else Func.share_code1 env "serialize" ("x", I32Type) [I32Type] (fun env get_x -> - let (set_start, get_start) = new_local env "old_heap" in - let (set_end, get_end) = new_local env "end" in - let (set_tbl_size, get_tbl_size) = new_local env "tbl_size" in - let (set_databuf, get_databuf) = new_local env "databuf" in - - (* Remember where we start to copy to *) - Heap.get_heap_ptr ^^ - set_start ^^ - - (* Copy data *) - get_x ^^ - BitTagged.if_unboxed env (ValBlockType None) - (* We have a bit-tagged raw value. Put this into a singleton databuf, - which will be recognized as such by its size. - *) - ( Heap.alloc env 1l ^^ - get_x ^^ - store_ptr ^^ + then Func.share_code1 env name ("x", I32Type) [I32Type] (fun env _ -> G.i Unreachable) + else Func.share_code1 env name ("x", I32Type) [I32Type] (fun env get_x -> + match Type.normalize t with + | Type.Prim Type.Text -> get_x ^^ Dfinity.compile_databuf_of_text env + | Type.Prim Type.Word32 -> get_x ^^ BoxedSmallWord.unbox env + | Type.Obj (Type.Actor, _) -> get_x ^^ Dfinity.unbox_reference env + | _ -> + let (set_data_size, get_data_size) = new_local env "data_size" in + let (set_refs_size, get_refs_size) = new_local env "refs_size" in - (* Remember the end *) - Heap.get_heap_ptr ^^ - set_end ^^ + (* Get object sizes *) + get_x ^^ + buffer_size env t ^^ + set_refs_size ^^ + set_data_size ^^ - (* Empty table of references *) - compile_unboxed_const 0l ^^ set_tbl_size - ) - (* We have real data on the heap. Copy. *) - ( get_x ^^ - serialize_go env ^^ - G.i Drop ^^ - - (* Remember the end *) - Heap.get_heap_ptr ^^ - set_end ^^ - - (* Adjust pointers *) - get_start ^^ - get_end ^^ - compile_unboxed_zero ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ - shift_pointers env ^^ - - (* Extract references, and remember how many there were *) - get_start ^^ - get_end ^^ - get_end ^^ - extract_references env ^^ - set_tbl_size - ) ^^ + let (set_data_start, get_data_start) = new_local env "data_start" in + let (set_refs_start, get_refs_start) = new_local env "refs_start" in - (* Create databuf *) - get_start ^^ - get_end ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ - G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ - set_databuf ^^ + Heap.get_heap_ptr ^^ + set_data_start ^^ - (* Append this reference at the end of the extracted references *) - get_end ^^ - get_tbl_size ^^ compile_mul_const Heap.word_size ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - get_databuf ^^ - store_ptr ^^ - (* And bump table end *) - get_tbl_size ^^ compile_add_const 1l ^^ set_tbl_size ^^ - - (* Reset the heap counter, to free some space *) - get_start ^^ - Heap.set_heap_ptr ^^ - Heap.grow_memory env ^^ - - (* Finally, create elembuf *) - get_end ^^ - get_tbl_size ^^ - G.i (Call (nr (Dfinity.elem_externalize_i env))) + Heap.get_heap_ptr ^^ + get_data_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + set_refs_start ^^ + + (* Allocate space, if needed *) + get_refs_start ^^ + get_refs_size ^^ + compile_divU_const Heap.word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + Heap.grow_memory env ^^ + + (* Serialize x into the buffer *) + get_x ^^ + get_data_start ^^ + get_refs_start ^^ + compile_unboxed_const 1l ^^ (* Leave space for databuf *) + serialize_go env t ^^ + + (* Sanity check: Did we fill exactly the buffer *) + get_refs_size ^^ compile_add_const 1l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ + + get_data_start ^^ get_data_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ + + (* Create databuf, and store at beginning of ref area *) + get_refs_start ^^ + get_data_start ^^ + get_data_size ^^ + G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ + store_unskewed_ptr ^^ + + if has_no_references t + then + (* Sanity check: Really no references *) + get_refs_size ^^ + G.i (Test (Wasm.Values.I32 I32Op.Eqz)) ^^ + G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ + (* If there are no references, just return the databuf *) + get_refs_start ^^ + load_unskewed_ptr + else + (* Finally, create elembuf *) + get_refs_start ^^ + get_refs_size ^^ compile_add_const 1l ^^ + G.i (Call (nr (Dfinity.elem_externalize_i env))) ) - let serialize_n env n = match n with - | 0 -> G.nop - | 1 -> serialize env - | _ -> - let name = Printf.sprintf "serialize_%i" n in - let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i, I32Type) in - let retty = Lib.List.make n I32Type in - Func.share_code env name args retty (fun env -> - G.table n (fun i -> - G.i (LocalGet (nr (Int32.of_int i))) ^^ serialize env - ) - ) + let deserialize_text env get_databuf = + let (set_data_size, get_data_size) = new_local env "data_size" in + let (set_x, get_x) = new_local env "x" in - let deserialize env = - Func.share_code1 env "deserialize" ("elembuf", I32Type) [I32Type] (fun env get_elembuf -> - let (set_databuf, get_databuf) = new_local env "databuf" in - let (set_start, get_start) = new_local env "start" in - let (set_data_len, get_data_len) = new_local env "data_len" in - let (set_tbl_size, get_tbl_size) = new_local env "tbl_size" in - - (* new positions *) - Heap.get_heap_ptr ^^ - set_start ^^ - - get_elembuf ^^ G.i (Call (nr (Dfinity.elem_length_i env))) ^^ - set_tbl_size ^^ - - (* Get scratch space (one word) *) - Heap.alloc env 1l ^^ G.i Drop ^^ - get_start ^^ Heap.set_heap_ptr ^^ - - (* First load databuf reference (last entry) at the heap position somehow *) - (* now load the databuf *) - get_start ^^ - compile_unboxed_const 1l ^^ - get_elembuf ^^ - get_tbl_size ^^ compile_sub_const 1l ^^ - G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ - get_start ^^ load_ptr ^^ - set_databuf ^^ - - get_databuf ^^ G.i (Call (nr (Dfinity.data_length_i env))) ^^ - set_data_len ^^ - - (* Get some scratch space *) - get_data_len ^^ Heap.dyn_alloc_bytes env ^^ G.i Drop ^^ - get_start ^^ Heap.set_heap_ptr ^^ - - (* Load data from databuf *) - get_start ^^ - get_data_len ^^ - get_databuf ^^ - compile_unboxed_const 0l ^^ - G.i (Call (nr (Dfinity.data_internalize_i env))) ^^ - - (* Check if we got something unboxed (data buf size 1 word) *) - get_data_len ^^ - compile_unboxed_const Heap.word_size ^^ - G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ - G.if_ (ValBlockType (Some I32Type)) - (* Yes, we got something unboxed. Return it, and do _not_ bump the heap pointer *) - ( get_start ^^ load_ptr ) - (* No, it is actual heap-data *) - ( (* update heap pointer *) - get_start ^^ - get_data_len ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - Heap.set_heap_ptr ^^ - Heap.grow_memory env ^^ - - (* Fix pointers *) - get_start ^^ - Heap.get_heap_ptr ^^ - get_start ^^ - shift_pointers env ^^ - - (* Load references *) - Heap.get_heap_ptr ^^ - get_tbl_size ^^ compile_sub_const 1l ^^ + get_databuf ^^ + G.i (Call (nr (Dfinity.data_length_i env))) ^^ + set_data_size ^^ + + get_data_size ^^ + Text.alloc env ^^ + set_x ^^ + + get_x ^^ Text.payload_ptr_unskewed ^^ + get_data_size ^^ + get_databuf ^^ + compile_unboxed_const 0l ^^ + G.i (Call (nr (Dfinity.data_internalize_i env))) ^^ + + get_x + + + let deserialize env t = + let name = "@deserialize<" ^ typ_id t ^ ">" in + Func.share_code1 env name ("elembuf", I32Type) [I32Type] (fun env get_elembuf -> + match Type.normalize t with + | Type.Prim Type.Text -> deserialize_text env get_elembuf + | Type.Prim Type.Word32 -> get_elembuf ^^ BoxedSmallWord.box env + | Type.Obj (Type.Actor, _) -> get_elembuf ^^ Dfinity.box_reference env + | _ -> + let (set_data_size, get_data_size) = new_local env "data_size" in + let (set_refs_size, get_refs_size) = new_local env "refs_size" in + let (set_data_start, get_data_start) = new_local env "data_start" in + let (set_refs_start, get_refs_start) = new_local env "refs_start" in + let (set_databuf, get_databuf) = new_local env "databuf" in + + begin + if has_no_references t + then + (* We have no elembuf wrapper, so the argument is the databuf *) + compile_unboxed_const 0l ^^ set_refs_start ^^ + get_elembuf ^^ set_databuf + else + (* Allocate space for the elem buffer *) + get_elembuf ^^ + G.i (Call (nr (Dfinity.elem_length_i env))) ^^ + set_refs_size ^^ + + get_refs_size ^^ + Array.alloc env ^^ + compile_add_const Array.header_size ^^ + compile_add_const ptr_unskew ^^ + set_refs_start ^^ + + (* Copy elembuf *) + get_refs_start ^^ + get_refs_size ^^ get_elembuf ^^ compile_unboxed_const 0l ^^ G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ - (* Fix references *) - (* Extract references *) - get_start ^^ - Heap.get_heap_ptr ^^ - Heap.get_heap_ptr ^^ - intract_references env ^^ - - (* return allocated thing *) - get_start - ) + (* Get databuf *) + get_refs_start ^^ + load_unskewed_ptr ^^ + set_databuf + end ^^ + + (* Allocate space for the data buffer *) + get_databuf ^^ + G.i (Call (nr (Dfinity.data_length_i env))) ^^ + set_data_size ^^ + + get_data_size ^^ + compile_add_const 3l ^^ + compile_divU_const Heap.word_size ^^ + Array.alloc env ^^ + compile_add_const Array.header_size ^^ + compile_add_const ptr_unskew ^^ + set_data_start ^^ + + (* Copy data *) + get_data_start ^^ + get_data_size ^^ + get_databuf ^^ + compile_unboxed_const 0l ^^ + G.i (Call (nr (Dfinity.data_internalize_i env))) ^^ + + (* Go! *) + get_data_start ^^ + get_refs_start ^^ + deserialize_go env t ^^ + G.i Drop ) + let dfinity_type t = match Type.normalize t with + | Type.Prim Type.Text -> CustomSections.DataBuf + | Type.Prim Type.Word32 -> CustomSections.I32 + | Type.Obj (Type.Actor, _) -> CustomSections.ActorRef + | t' when has_no_references t' -> CustomSections.DataBuf + | _ -> CustomSections.ElemBuf end (* Serialization *) @@ -2711,11 +3231,15 @@ module GC = struct (could be mutable array of pointers, similar to the reference table) *) + let gc_enabled = true + (* If the pointer at ptr_loc points after begin_from_space, copy to after end_to_space, and replace it with a pointer, adjusted for where the object will be finally. *) + (* Returns the new end of to_space *) (* Invariant: Must not be called on the same pointer twice. *) - let evacuate env = Func.share_code4 env "evaucate" (("begin_from_space", I32Type), ("begin_to_space", I32Type), ("end_to_space", I32Type), ("ptr_loc", I32Type)) [I32Type] (fun env get_begin_from_space get_begin_to_space get_end_to_space get_ptr_loc -> + (* All pointers, including ptr_loc and space end markers, are skewed *) + let evacuate env = Func.share_code4 env "evacuate" (("begin_from_space", I32Type), ("begin_to_space", I32Type), ("end_to_space", I32Type), ("ptr_loc", I32Type)) [I32Type] (fun env get_begin_from_space get_begin_to_space get_end_to_space get_ptr_loc -> let (set_len, get_len) = new_local env "len" in let (set_new_ptr, get_new_ptr) = new_local env "new_ptr" in @@ -2745,9 +3269,9 @@ module GC = struct ] ^^ (* Copy the referenced object to to space *) - get_obj ^^ Serialization.object_size env ^^ set_len ^^ + get_obj ^^ HeapTraversal.object_size env ^^ set_len ^^ - get_obj ^^ get_end_to_space ^^ get_len ^^ Heap.memcpy env ^^ + get_obj ^^ get_end_to_space ^^ get_len ^^ Heap.memcpy_words_skewed env ^^ (* Calculate new pointer *) get_end_to_space ^^ @@ -2771,22 +3295,24 @@ module GC = struct (* Calculate new end of to space *) get_end_to_space ^^ - get_len ^^ + get_len ^^ compile_mul_const Heap.word_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ) let register env (end_of_static_space : int32) = Func.define_built_in env "collect" [] [] (fun env -> + if not gc_enabled then G.nop else + (* Copy all roots. *) let (set_begin_from_space, get_begin_from_space) = new_local env "begin_from_space" in let (set_begin_to_space, get_begin_to_space) = new_local env "begin_to_space" in let (set_end_to_space, get_end_to_space) = new_local env "end_to_space" in - compile_unboxed_const end_of_static_space ^^ set_begin_from_space ^^ - Heap.get_heap_ptr ^^ set_begin_to_space ^^ - Heap.get_heap_ptr ^^ set_end_to_space ^^ + compile_unboxed_const end_of_static_space ^^ compile_add_const ptr_skew ^^ set_begin_from_space ^^ + Heap.get_skewed_heap_ptr ^^ set_begin_to_space ^^ + Heap.get_skewed_heap_ptr ^^ set_end_to_space ^^ - (* Common arguments for evalcuate *) + (* Common arguments for evacuate *) let evac get_ptr_loc = get_begin_from_space ^^ get_begin_to_space ^^ @@ -2795,35 +3321,36 @@ module GC = struct evacuate env ^^ set_end_to_space in - (* Go through the roots, and evacaute them *) + (* Go through the roots, and evacuate them *) ClosureTable.get_counter ^^ from_0_to_n env (fun get_i -> evac ( get_i ^^ compile_add_const 1l ^^ compile_mul_const Heap.word_size ^^ - compile_add_const ClosureTable.loc + compile_add_const ClosureTable.loc ^^ + compile_add_const ptr_skew )) ^^ - Serialization.walk_heap_from_to env - (compile_unboxed_const ClosureTable.table_end) - (compile_unboxed_const end_of_static_space) - (fun get_x -> Serialization.for_each_pointer env get_x evac) ^^ + HeapTraversal.walk_heap_from_to env + (compile_unboxed_const Int32.(add ClosureTable.table_end ptr_skew)) + (compile_unboxed_const Int32.(add end_of_static_space ptr_skew)) + (fun get_x -> HeapTraversal.for_each_pointer env get_x evac) ^^ (* Go through the to-space, and evacuate that. Note that get_end_to_space changes as we go, but walk_heap_from_to can handle that. *) - Serialization.walk_heap_from_to env + HeapTraversal.walk_heap_from_to env get_begin_to_space get_end_to_space - (fun get_x -> Serialization.for_each_pointer env get_x evac) ^^ + (fun get_x -> HeapTraversal.for_each_pointer env get_x evac) ^^ (* Copy the to-space to the beginning of memory. *) - get_begin_to_space ^^ - get_begin_from_space ^^ + get_begin_to_space ^^ compile_add_const ptr_unskew ^^ + get_begin_from_space ^^ compile_add_const ptr_unskew ^^ get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ Heap.memcpy env ^^ (* Reset the heap pointer *) - get_begin_from_space ^^ + get_begin_from_space ^^ compile_add_const ptr_unskew ^^ get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ Heap.set_heap_ptr @@ -2837,7 +3364,7 @@ module StackRep = struct open SR (* - Most expression have a “preferred”, most optimal, form. Hence, + Most expressions have a “preferred”, most optimal, form. Hence, compile_exp put them on the stack in that form, and also returns the form it chose. @@ -2849,12 +3376,17 @@ module StackRep = struct let of_arity n = if n = 1 then Vanilla else UnboxedTuple n + let refs_of_arity n = + if n = 1 then UnboxedReference else UnboxedRefTuple n + (* The stack rel of a primitive type, i.e. what the binary operators expect *) let of_type : Type.typ -> t = function | Type.Prim Type.Bool -> bool | Type.Prim Type.Nat -> UnboxedInt64 | Type.Prim Type.Int -> UnboxedInt64 + | Type.Prim Type.Word64 -> UnboxedInt64 | Type.Prim Type.Word32 -> UnboxedWord32 + | Type.Prim Type.(Word8 | Word16 | Char) -> Vanilla | Type.Prim Type.Text -> Vanilla | p -> todo "of_type" (Arrange_ir.typ p) Vanilla @@ -2866,6 +3398,9 @@ module StackRep = struct | UnboxedTuple 0 -> ValBlockType None | UnboxedTuple 1 -> ValBlockType (Some I32Type) | UnboxedTuple n -> VarBlockType (nr (E.func_type env (FuncType ([], Lib.List.make n I32Type)))) + | UnboxedRefTuple 0 -> ValBlockType None + | UnboxedRefTuple 1 -> ValBlockType (Some I32Type) + | UnboxedRefTuple n -> VarBlockType (nr (E.func_type env (FuncType ([], Lib.List.make n I32Type)))) | StaticThing _ -> ValBlockType None | Unreachable -> ValBlockType None @@ -2875,6 +3410,7 @@ module StackRep = struct | UnboxedWord32 -> "UnboxedWord32" | UnboxedReference -> "UnboxedReference" | UnboxedTuple n -> Printf.sprintf "UnboxedTuple %d" n + | UnboxedRefTuple n -> Printf.sprintf "UnboxedRefTuple %d" n | Unreachable -> "Unreachable" | StaticThing _ -> "StaticThing" @@ -2897,18 +3433,46 @@ module StackRep = struct | UnboxedWord32 -> G.i Drop | UnboxedReference -> G.i Drop | UnboxedTuple n -> G.table n (fun _ -> G.i Drop) + | UnboxedRefTuple n -> G.table n (fun _ -> G.i Drop) | StaticThing _ -> G.nop | Unreachable -> G.nop let materialize env = function | StaticFun fi -> Var.static_fun_pointer env fi - let deferred_of_static_think env s = + let deferred_of_static_thing env s = { materialize = (fun env -> (StaticThing s, G.nop)) ; materialize_vanilla = (fun env -> materialize env s) + ; is_local = false } - let adjust env (sr_in : t) sr_out = + let unbox_reference_n env n = match n with + | 0 -> G.nop + | 1 -> Dfinity.unbox_reference env + | _ -> + let name = Printf.sprintf "unbox_reference_n %i" n in + let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i, I32Type) in + let retty = Lib.List.make n I32Type in + Func.share_code env name args retty (fun env -> + G.table n (fun i -> + G.i (LocalGet (nr (Int32.of_int i))) ^^ Dfinity.unbox_reference env + ) + ) + + let box_reference_n env n = match n with + | 0 -> G.nop + | 1 -> Dfinity.box_reference env + | _ -> + let name = Printf.sprintf "box_reference_n %i" n in + let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i, I32Type) in + let retty = Lib.List.make n I32Type in + Func.share_code env name args retty (fun env -> + G.table n (fun i -> + G.i (LocalGet (nr (Int32.of_int i))) ^^ Dfinity.box_reference env + ) + ) + + let rec adjust env (sr_in : t) sr_out = if sr_in = sr_out then G.nop else match sr_in, sr_out with @@ -2918,6 +3482,15 @@ module StackRep = struct | UnboxedTuple n, Vanilla -> Tuple.from_stack env n | Vanilla, UnboxedTuple n -> Tuple.to_stack env n + | UnboxedRefTuple n, UnboxedTuple m when n = m -> box_reference_n env n + | UnboxedTuple n, UnboxedRefTuple m when n = m -> unbox_reference_n env n + + | UnboxedRefTuple n, sr -> + box_reference_n env n ^^ adjust env (UnboxedTuple n) sr + | sr, UnboxedRefTuple n -> + adjust env sr (UnboxedTuple n) ^^ unbox_reference_n env n + + | UnboxedInt64, Vanilla -> BoxedInt.box env | Vanilla, UnboxedInt64 -> BoxedInt.unbox env @@ -2935,6 +3508,8 @@ module StackRep = struct (to_string sr_in) (to_string sr_out); G.nop + + end (* StackRep *) @@ -2974,23 +3549,36 @@ module FuncDec = struct Dfinity.compile_databuf_of_bytes env name ^^ export_self_message env + let bind_args env0 as_ bind_arg = + let rec go i env = function + | [] -> env + | a::as_ -> + let get = G.i (LocalGet (nr (Int32.of_int i))) in + let env' = bind_arg env a get in + go (i+1) env' as_ in + go 1 (* skip closure*) env0 as_ + (* Create a WebAssembly func from a pattern (for the argument) and the body. Parameter `captured` should contain the, well, captured local variables that the function will find in the closure. *) - let compile_local_function env cc restore_env mk_pat mk_body at = - let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i, I32Type) in + let compile_local_function env cc restore_env args mk_body at = + let arg_names = List.map (fun a -> a.it, I32Type) args in let retty = Lib.List.make cc.Value.n_res I32Type in - Func.of_body env (["clos", I32Type] @ args) retty (fun env1 -> G.with_region at ( + Func.of_body env (["clos", I32Type] @ arg_names) retty (fun env1 -> G.with_region at ( let get_closure = G.i (LocalGet (nr 0l)) in let (env2, closure_code) = restore_env env1 get_closure in - (* Destruct the argument *) - let (env3, destruct_args_code) = mk_pat env2 in + (* Add arguments to the environment *) + let env3 = bind_args env2 args (fun env a get -> + E.add_local_deferred env a.it + { materialize = (fun env -> SR.Vanilla, get) + ; materialize_vanilla = (fun _ -> get) + ; is_local = true + } + ) in closure_code ^^ - let get i = G.i (LocalGet (nr (Int32.(add 1l (of_int i))))) in - destruct_args_code get ^^ mk_body env3 )) @@ -3002,10 +3590,10 @@ module FuncDec = struct - Do GC at the end - Fake orthogonal persistence *) - let compile_message env cc restore_env mk_pat mk_body at = - let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i, I32Type) in + let compile_message env cc restore_env args mk_body at = + let arg_names = List.map (fun a -> a.it, I32Type) args in assert (cc.Value.n_res = 0); - Func.of_body env (["clos", I32Type] @ args) [] (fun env1 -> G.with_region at ( + Func.of_body env (["clos", I32Type] @ arg_names) [] (fun env1 -> G.with_region at ( (* Restore memory *) OrthogonalPersistence.restore_mem env1 ^^ @@ -3017,14 +3605,17 @@ module FuncDec = struct let (env2, closure_code) = restore_env env1 get_closure in - (* Destruct the argument *) - let (env3, destruct_args_code) = mk_pat env2 in + (* Add arguments to the environment, as unboxed references *) + let env3 = bind_args env2 args (fun env a get -> + E.add_local_deferred env a.it + { materialize = (fun env -> SR.UnboxedReference, get) + ; materialize_vanilla = (fun env -> + get ^^ StackRep.adjust env SR.UnboxedReference SR.Vanilla) + ; is_local = true + } + ) in closure_code ^^ - let get i = - G.i (LocalGet (nr (Int32.(add 1l (of_int i))))) ^^ - Serialization.deserialize env in - destruct_args_code get ^^ mk_body env3 ^^ (* Collect garbage *) @@ -3060,16 +3651,16 @@ module FuncDec = struct ) (* Compile a closed function declaration (has no free variables) *) - let closed pre_env cc name mk_pat mk_body at = + let closed pre_env cc name args mk_body at = let (fi, fill) = E.reserve_fun pre_env name in ( SR.StaticFun fi, fun env -> let restore_no_env env1 _ = (env1, G.nop) in - let f = compile_local_function env cc restore_no_env mk_pat mk_body at in + let f = compile_local_function env cc restore_no_env args mk_body at in fill f ) (* Compile a closure declaration (has free variables) *) - let closure env cc name captured mk_pat mk_body at = + let closure env cc name captured args mk_body at = let is_local = cc.Value.sort <> Type.Sharable in let (set_clos, get_clos) = new_local env (name ^ "_clos") in @@ -3100,15 +3691,18 @@ module FuncDec = struct let f = if is_local - then compile_local_function env cc restore_env mk_pat mk_body at - else compile_message env cc restore_env mk_pat mk_body at in + then compile_local_function env cc restore_env args mk_body at + else compile_message env cc restore_env args mk_body at in let fi = E.add_fun env f name in if not is_local then - E.add_dfinity_type env (fi, - CustomSections.(I32 :: Lib.List.make cc.Value.n_args ElemBuf) - ); + E.add_dfinity_type env (fi, + CustomSections.I32 :: + List.map ( + fun a -> Serialization.dfinity_type (Type.as_serialized a.note) + ) args + ); let code = (* Allocate a heap object for the closure *) @@ -3148,14 +3742,14 @@ module FuncDec = struct ClosureTable.remember_closure env ^^ G.i (Call (nr (Dfinity.func_bind_i env))) - let lit env how name cc captured mk_pat mk_body at = + let lit env how name cc captured args mk_body at = let is_local = cc.Value.sort <> Type.Sharable in if not is_local && E.mode env <> DfinityMode then SR.Unreachable, G.i Unreachable else (* TODO: Can we create a static function here? Do we ever have to? *) - closure env cc name captured mk_pat mk_body at + closure env cc name captured args mk_body at end (* FuncDec *) @@ -3231,9 +3825,21 @@ let compile_lit env lit = Syntax.(match lit with | NatLit n -> SR.UnboxedInt64, (try compile_const_64 (Big_int.int64_of_big_int n) with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i Unreachable) + | Word8Lit n -> SR.Vanilla, + (try compile_unboxed_const (Value.Word8.to_bits n) + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" (Int32.to_int (Value.Word8.to_bits n)); G.i Unreachable) + | Word16Lit n -> SR.Vanilla, + (try compile_unboxed_const (Value.Word16.to_bits n) + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" (Int32.to_int (Value.Word16.to_bits n)); G.i Unreachable) | Word32Lit n -> SR.UnboxedWord32, (try compile_unboxed_const n - with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" (Int32.to_int n); G.i Unreachable) (* TODO: check we are 64 bit *) + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" (Int32.to_int n); G.i Unreachable) + | Word64Lit n -> SR.UnboxedInt64, + (try compile_const_64 n + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" (Int64.to_int n); G.i Unreachable) + | CharLit c -> SR.Vanilla, + (try compile_unboxed_const Int32.(shift_left (of_int c) 8) + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" c; G.i Unreachable) | NullLit -> SR.Vanilla, Opt.null | TextLit t -> SR.Vanilla, Text.lit env t | _ -> todo "compile_lit" (Arrange.lit lit) (SR.Vanilla, G.i Unreachable) @@ -3244,63 +3850,141 @@ let compile_lit_as env sr_out lit = code ^^ StackRep.adjust env sr_in sr_out let compile_unop env t op = Syntax.(match op, t with - | NegOp, Type.Prim Type.Int -> + | NegOp, Type.(Prim (Int | Word64)) -> SR.UnboxedInt64, Func.share_code1 env "neg" ("n", I64Type) [I64Type] (fun env get_n -> compile_const_64 0L ^^ get_n ^^ G.i (Binary (Wasm.Values.I64 I64Op.Sub)) ) - | NegOp, Type.Prim Type.Word16 -> - SR.UnboxedWord32, - Func.share_code env "neg16" ["n", I32Type] [I32Type] (fun env -> - let get_n = G.i (LocalGet (nr 0l)) in - compile_unboxed_zero ^^ - get_n ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ - compile_unboxed_const 0xFFFFl ^^ - G.i (Binary (Wasm.Values.I32 I32Op.And)) - ) - | NegOp, Type.Prim Type.Word32 -> - SR.UnboxedWord32, - Func.share_code env "neg32" ["n", I32Type] [I32Type] (fun env -> - let get_n = G.i (LocalGet (nr 0l)) in + | NegOp, Type.Prim Type.(Word8 | Word16 | Word32) -> + StackRep.of_type t, + Func.share_code1 env "neg32" ("n", I32Type) [I32Type] (fun env get_n -> compile_unboxed_zero ^^ get_n ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ) - | PosOp, Type.Prim (Type.Int | Type.Nat) -> - SR.UnboxedInt64, - G.nop - | PosOp, Type.Prim (Type.Word8 | Type.Word16 | Type.Word32) -> - SR.UnboxedWord32, - G.nop + | NotOp, Type.(Prim Word64) -> + SR.UnboxedInt64, + compile_const_64 (-1L) ^^ + G.i (Binary (Wasm.Values.I64 I64Op.Xor)) + | NotOp, Type.Prim Type.(Word8 | Word16 | Word32 as ty) -> + StackRep.of_type t, compile_unboxed_const (UnboxedSmallWord.mask_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Xor)) | _ -> todo "compile_unop" (Arrange.unop op) (SR.Vanilla, G.i Unreachable) ) + (* This returns a single StackRep, to be used for both arguments and the result. One could imagine operators that require or produce different StackReps, but none of these do, so a single value is fine. *) -let compile_binop env t op = +let rec compile_binop env t op = StackRep.of_type t, Syntax.(match t, op with - | Type.Prim Type.Nat, AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) - | Type.Prim Type.Nat, SubOp -> + | Type.(Prim (Nat | Int | Word64)), AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) + | Type.Prim Type.Nat, SubOp -> Func.share_code2 env "nat_sub" (("n1", I64Type), ("n2", I64Type)) [I64Type] (fun env get_n1 get_n2 -> get_n1 ^^ get_n2 ^^ G.i (Compare (Wasm.Values.I64 I64Op.LtU)) ^^ G.if_ (StackRep.to_block_type env SR.UnboxedInt64) (G.i Unreachable) (get_n1 ^^ get_n2 ^^ G.i (Binary (Wasm.Values.I64 I64Op.Sub))) ) - | Type.Prim Type.Nat, MulOp -> G.i (Binary (Wasm.Values.I64 I64Op.Mul)) - | Type.Prim Type.Nat, DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivU)) - | Type.Prim Type.Nat, ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemU)) - | Type.Prim Type.Int, AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) - | Type.Prim Type.Int, SubOp -> G.i (Binary (Wasm.Values.I64 I64Op.Sub)) - | Type.Prim Type.Int, MulOp -> G.i (Binary (Wasm.Values.I64 I64Op.Mul)) - | Type.Prim Type.Int, DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivS)) - | Type.Prim Type.Int, ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemS)) + | Type.(Prim (Nat | Int | Word64)), MulOp -> G.i (Binary (Wasm.Values.I64 I64Op.Mul)) + | Type.(Prim (Nat | Word64)), DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivU)) + | Type.(Prim (Nat | Word64)), ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemU)) + | Type.(Prim (Int | Word64)), SubOp -> G.i (Binary (Wasm.Values.I64 I64Op.Sub)) + | Type.(Prim Int), DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivS)) + | Type.(Prim Int), ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemS)) + + | Type.Prim Type.(Word8 | Word16 | Word32), AddOp -> G.i (Binary (Wasm.Values.I32 I32Op.Add)) + | Type.Prim Type.(Word8 | Word16 | Word32), SubOp -> G.i (Binary (Wasm.Values.I32 I32Op.Sub)) + | Type.(Prim (Word8|Word16|Word32 as ty)), MulOp -> UnboxedSmallWord.lsb_adjust ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Mul)) + | Type.Prim Type.(Word8 | Word16 | Word32), DivOp -> G.i (Binary (Wasm.Values.I32 I32Op.DivU)) + | Type.Prim Type.(Word8 | Word16 | Word32), ModOp -> G.i (Binary (Wasm.Values.I32 I32Op.RemU)) + | Type.(Prim (Word8|Word16|Word32 as ty)), PowOp -> + let rec pow () = Func.share_code2 env (UnboxedSmallWord.name_of_type ty "pow") + (("n", I32Type), ("exp", I32Type)) [I32Type] + Wasm.Values.(fun env get_n get_exp -> + let one = compile_unboxed_const (UnboxedSmallWord.const_of_type ty 1l) in + let (set_res, get_res) = new_local env "res" in + let mul = snd (compile_binop env t MulOp) in + let square_recurse_with_shifted sanitize = + get_n ^^ get_exp ^^ compile_shrU_const 1l ^^ sanitize ^^ + pow () ^^ set_res ^^ get_res ^^ get_res ^^ mul + in get_exp ^^ G.i (Test (I32 I32Op.Eqz)) ^^ + G.if_ (StackRep.to_block_type env SR.UnboxedWord32) + one + (get_exp ^^ one ^^ G.i (Binary (I32 I32Op.And)) ^^ G.i (Test (I32 I32Op.Eqz)) ^^ + G.if_ (StackRep.to_block_type env SR.UnboxedWord32) + (square_recurse_with_shifted G.nop) + (get_n ^^ + square_recurse_with_shifted (UnboxedSmallWord.sanitize_word_result ty) ^^ + mul))) + in pow () + | Type.(Prim Int), PowOp -> + let _, pow = compile_binop env Type.(Prim Nat) PowOp in + let (set_n, get_n) = new_local64 env "n" in + let (set_exp, get_exp) = new_local64 env "exp" + in set_exp ^^ set_n ^^ get_exp ^^ compile_const_64 0L ^^ G.i (Compare (Wasm.Values.I64 I64Op.LtS)) ^^ + G.if_ (StackRep.to_block_type env SR.UnboxedInt64) + (G.i Unreachable) + (get_n ^^ get_exp ^^ pow) + | Type.(Prim (Nat|Word64)), PowOp -> + let rec pow () = Func.share_code2 env "pow" + (("n", I64Type), ("exp", I64Type)) [I64Type] + Wasm.Values.(fun env get_n get_exp -> + let one = compile_const_64 1L in + let (set_res, get_res) = new_local64 env "res" in + let mul = snd (compile_binop env t MulOp) in + let square_recurse_with_shifted = + get_n ^^ get_exp ^^ one ^^ + G.i (Binary (I64 I64Op.ShrU)) ^^ + pow () ^^ set_res ^^ get_res ^^ get_res ^^ mul + in get_exp ^^ G.i (Test (I64 I64Op.Eqz)) ^^ + G.if_ (StackRep.to_block_type env SR.UnboxedInt64) + one + (get_exp ^^ one ^^ G.i (Binary (I64 I64Op.And)) ^^ G.i (Test (I64 I64Op.Eqz)) ^^ + G.if_ (StackRep.to_block_type env SR.UnboxedInt64) + square_recurse_with_shifted + (get_n ^^ + square_recurse_with_shifted ^^ + mul))) + in pow () + | Type.(Prim Word64), AndOp -> G.i (Binary (Wasm.Values.I64 I64Op.And)) + | Type.Prim Type.(Word8 | Word16 | Word32), AndOp -> G.i (Binary (Wasm.Values.I32 I32Op.And)) + | Type.(Prim Word64), OrOp -> G.i (Binary (Wasm.Values.I64 I64Op.Or)) + | Type.Prim Type.(Word8 | Word16 | Word32), OrOp -> G.i (Binary (Wasm.Values.I32 I32Op.Or)) + | Type.(Prim Word64), XorOp -> G.i (Binary (Wasm.Values.I64 I64Op.Xor)) + | Type.Prim Type.(Word8 | Word16 | Word32), XorOp -> G.i (Binary (Wasm.Values.I32 I32Op.Xor)) + | Type.(Prim Word64), ShLOp -> G.i (Binary (Wasm.Values.I64 I64Op.Shl)) + | Type.(Prim (Word8|Word16|Word32 as ty)), ShLOp -> UnboxedSmallWord.( + lsb_adjust ty ^^ clamp_shift_amount ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl))) + | Type.(Prim Word64), ShROp -> G.i (Binary (Wasm.Values.I64 I64Op.ShrU)) + | Type.(Prim (Word8|Word16|Word32 as ty)), ShROp -> UnboxedSmallWord.( + lsb_adjust ty ^^ clamp_shift_amount ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) ^^ + sanitize_word_result ty) + | Type.(Prim Word64), RotLOp -> G.i (Binary (Wasm.Values.I64 I64Op.Rotl)) + | Type.Prim Type. Word32, RotLOp -> G.i (Binary (Wasm.Values.I32 I32Op.Rotl)) + | Type.Prim Type.(Word8 | Word16 as ty), RotLOp -> UnboxedSmallWord.( + Func.share_code2 env (name_of_type ty "rotl") (("n", I32Type), ("by", I32Type)) [I32Type] + Wasm.Values.(fun env get_n get_by -> + let beside_adjust = compile_shrU_const (Int32.sub 32l (shift_of_type ty)) in + get_n ^^ get_n ^^ beside_adjust ^^ G.i (Binary (I32 I32Op.Or)) ^^ + get_by ^^ lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (I32 I32Op.Rotl)) ^^ + sanitize_word_result ty)) + | Type.(Prim Word64), RotROp -> G.i (Binary (Wasm.Values.I64 I64Op.Rotr)) + | Type.Prim Type. Word32, RotROp -> G.i (Binary (Wasm.Values.I32 I32Op.Rotr)) + | Type.Prim Type.(Word8 | Word16 as ty), RotROp -> UnboxedSmallWord.( + Func.share_code2 env (name_of_type ty "rotr") (("n", I32Type), ("by", I32Type)) [I32Type] + Wasm.Values.(fun env get_n get_by -> + get_n ^^ get_n ^^ lsb_adjust ty ^^ G.i (Binary (I32 I32Op.Or)) ^^ + get_by ^^ lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (I32 I32Op.Rotr)) ^^ + sanitize_word_result ty)) + | Type.Prim Type.Text, CatOp -> Text.concat env | _ -> todo "compile_binop" (Arrange.binop op) (G.i Unreachable) ) @@ -3308,10 +3992,25 @@ let compile_binop env t op = let compile_eq env t = match t with | Type.Prim Type.Text -> Text.compare env | Type.Prim Type.Bool -> G.i (Compare (Wasm.Values.I32 I32Op.Eq)) - | Type.Prim (Type.Nat | Type.Int) -> G.i (Compare (Wasm.Values.I64 I64Op.Eq)) - | Type.Prim Type.Word32 -> G.i (Compare (Wasm.Values.I32 I32Op.Eq)) + | Type.(Prim (Nat | Int | Word64)) -> G.i (Compare (Wasm.Values.I64 I64Op.Eq)) + | Type.(Prim (Word8 | Word16 | Word32 | Char)) -> G.i (Compare (Wasm.Values.I32 I32Op.Eq)) | _ -> todo "compile_eq" (Arrange.relop Syntax.EqOp) (G.i Unreachable) +let get_relops = Syntax.(function + | GeOp -> I64Op.GeU, I64Op.GeS, I32Op.GeU, I32Op.GeS + | GtOp -> I64Op.GtU, I64Op.GtS, I32Op.GtU, I32Op.GtS + | LeOp -> I64Op.LeU, I64Op.LeS, I32Op.LeU, I32Op.LeS + | LtOp -> I64Op.LtU, I64Op.LtS, I32Op.LtU, I32Op.LtS + | _ -> failwith "uncovered relop") + +let compile_comparison t op = + let u64op, s64op, u32op, s32op = get_relops op + in Type.(match t with + | (Nat | Word64) -> G.i (Compare (Wasm.Values.I64 u64op)) + | Int -> G.i (Compare (Wasm.Values.I64 s64op)) + | (Word8 | Word16 | Word32 | Char) -> G.i (Compare (Wasm.Values.I32 u32op)) + | _ -> todo "compile_comparison" (Arrange.prim t) (G.i Unreachable)) + let compile_relop env t op = StackRep.of_type t, Syntax.(match t, op with @@ -3319,20 +4018,13 @@ let compile_relop env t op = | _, NeqOp -> compile_eq env t ^^ G.if_ (StackRep.to_block_type env SR.bool) (Bool.lit false) (Bool.lit true) - | Type.Prim Type.Nat, GeOp -> G.i (Compare (Wasm.Values.I64 I64Op.GeU)) - | Type.Prim Type.Nat, GtOp -> G.i (Compare (Wasm.Values.I64 I64Op.GtU)) - | Type.Prim Type.Nat, LeOp -> G.i (Compare (Wasm.Values.I64 I64Op.LeU)) - | Type.Prim Type.Nat, LtOp -> G.i (Compare (Wasm.Values.I64 I64Op.LtU)) - | Type.Prim Type.Int, GeOp -> G.i (Compare (Wasm.Values.I64 I64Op.GeS)) - | Type.Prim Type.Int, GtOp -> G.i (Compare (Wasm.Values.I64 I64Op.GtS)) - | Type.Prim Type.Int, LeOp -> G.i (Compare (Wasm.Values.I64 I64Op.LeS)) - | Type.Prim Type.Int, LtOp -> G.i (Compare (Wasm.Values.I64 I64Op.LtS)) + | Type.Prim Type.(Nat | Int | Word8 | Word16 | Word32 | Word64 | Char as t1), op1 -> + compile_comparison t1 op1 | _ -> todo "compile_relop" (Arrange.relop op) (G.i Unreachable) ) - (* compile_lexp is used for expressions on the left of an -assignment operator, produces some code (with sideffect), and some pure code *) +assignment operator, produces some code (with side effect), and some pure code *) let rec compile_lexp (env : E.t) exp = (fun (sr,code) -> (sr, G.with_region exp.at code)) @@ match exp.it with @@ -3365,38 +4057,34 @@ and compile_exp (env : E.t) exp = | DotE (e, ({it = Name n;_} as name)) -> SR.Vanilla, compile_exp_vanilla env e ^^ - begin match Array.fake_object_idx env n with - | None -> Object.load_idx env e.note.note_typ name - | Some array_code -> - let (set_o, get_o) = new_local env "o" in - set_o ^^ - get_o ^^ - Tagged.branch env (ValBlockType (Some I32Type)) ( - [ Tagged.Object, get_o ^^ Object.load_idx env e.note.note_typ name - ; Tagged.Array, get_o ^^ array_code ] - ) - end + let selective tag = function + | None -> [] | Some code -> [ tag, code ] + in Tagged.branch_with env (ValBlockType (Some I32Type)) + (List.concat [ [Tagged.Object, Object.load_idx env e.note.note_typ name] + ; selective Tagged.Array (Array.fake_object_idx env n) + ; selective Tagged.Text (Text.fake_object_idx env n)]) | ActorDotE (e, ({it = Name n;_} as name)) -> SR.UnboxedReference, if E.mode env <> DfinityMode then G.i Unreachable else compile_exp_as env SR.UnboxedReference e ^^ actor_fake_object_idx env {name with it = n} (* We only allow prims of certain shapes, as they occur in the prelude *) - (* Binary prims *) - | CallE (_, ({ it = PrimE p; _} as pe), _, { it = TupE [e1;e2]; _}) -> - SR.Vanilla, - begin - compile_exp_vanilla env e1 ^^ - compile_exp_vanilla env e2 ^^ - match p with - | "Array.init" -> Array.init env - | "Array.tabulate" -> Array.tabulate env - | _ -> todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) - end - (* Unary prims *) - | CallE (_, ({ it = PrimE p; _} as pe), _, e) -> + | CallE (_, ({ it = PrimE p; _} as pe), typ_args, e) -> begin + (* First check for all unary prims. *) match p with + | "@serialize" -> + SR.UnboxedReference, + let t = match typ_args with [t] -> t | _ -> assert false in + compile_exp_vanilla env e ^^ + Serialization.serialize env t + + | "@deserialize" -> + SR.Vanilla, + let t = match typ_args with [t] -> t | _ -> assert false in + compile_exp_as env SR.UnboxedReference e ^^ + Serialization.deserialize env t + | "abs" -> SR.Vanilla, compile_exp_vanilla env e ^^ @@ -3404,48 +4092,99 @@ and compile_exp (env : E.t) exp = | "Nat->Word8" | "Int->Word8" -> - SR.UnboxedWord32, + SR.Vanilla, compile_exp_as env SR.UnboxedInt64 e ^^ - Prim.prim_maskToWord32 0xFFl env + Prim.prim_shiftToWordN (UnboxedSmallWord.shift_of_type Type.Word8) | "Nat->Word16" | "Int->Word16" -> - SR.UnboxedWord32, + SR.Vanilla, compile_exp_as env SR.UnboxedInt64 e ^^ - Prim.prim_maskToWord32 0xFFFFl env + Prim.prim_shiftToWordN (UnboxedSmallWord.shift_of_type Type.Word16) | "Nat->Word32" | "Int->Word32" -> SR.UnboxedWord32, compile_exp_as env SR.UnboxedInt64 e ^^ - Prim.prim_intToWord32 env + Prim.prim_intToWord32 + + | "Nat->Word64" + | "Int->Word64" -> + let sr, code = compile_exp env e in sr, code ^^ G.nop + + | "Char->Word32" -> + SR.UnboxedWord32, + compile_exp_vanilla env e ^^ + UnboxedSmallWord.unbox_codepoint | "Word8->Nat" -> SR.UnboxedInt64, - compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_maskedWord32toNat 0xFFl env + compile_exp_vanilla env e ^^ + Prim.prim_shiftWordNtoUnsigned (UnboxedSmallWord.shift_of_type Type.Word8) | "Word8->Int" -> SR.UnboxedInt64, - compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_by_shiftWord32toInt 24l env + compile_exp_vanilla env e ^^ + Prim.prim_shiftWordNtoSigned (UnboxedSmallWord.shift_of_type Type.Word8) | "Word16->Nat" -> SR.UnboxedInt64, - compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_maskedWord32toNat 0xFFFFl env + compile_exp_vanilla env e ^^ + Prim.prim_shiftWordNtoUnsigned (UnboxedSmallWord.shift_of_type Type.Word16) | "Word16->Int" -> SR.UnboxedInt64, - compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_by_shiftWord32toInt 16l env + compile_exp_vanilla env e ^^ + Prim.prim_shiftWordNtoSigned (UnboxedSmallWord.shift_of_type Type.Word16) | "Word32->Nat" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_word32toNat env + Prim.prim_word32toNat | "Word32->Int" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_word32toInt env + Prim.prim_word32toInt + + | "Word64->Nat" + | "Word64->Int" -> + let sr, code = compile_exp env e in sr, code ^^ G.nop + + | "Word32->Char" -> + SR.Vanilla, + compile_exp_as env SR.UnboxedWord32 e ^^ + UnboxedSmallWord.box_codepoint + + | "Int~hash" -> + SR.UnboxedWord32, + compile_exp_as env SR.UnboxedInt64 e ^^ + Prim.prim_hashInt env + + | "popcnt" -> + SR.UnboxedWord32, + compile_exp_as env SR.UnboxedWord32 e ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) + | "popcnt8" + | "popcnt16" -> + SR.Vanilla, + compile_exp_vanilla env e ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) ^^ + UnboxedSmallWord.msb_adjust (match p with | "popcnt8" -> Type.Word8 | _ -> Type.Word16) + | "popcnt64" -> + SR.UnboxedInt64, + compile_exp_as env SR.UnboxedInt64 e ^^ + G.i (Unary (Wasm.Values.I64 I64Op.Popcnt)) + | "clz" -> SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Clz)) + | "clz8" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.clz_kernel Type.Word8 + | "clz16" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.clz_kernel Type.Word16 + | "clz64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Clz)) + | "ctz" -> SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) + | "ctz8" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.ctz_kernel Type.Word8 + | "ctz16" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.ctz_kernel Type.Word16 + | "ctz64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Ctz)) + + | "Char->Text" -> + SR.Vanilla, + compile_exp_vanilla env e ^^ + Text.prim_showChar env | "printInt" -> SR.unit, @@ -3455,9 +4194,35 @@ and compile_exp (env : E.t) exp = SR.unit, compile_exp_vanilla env e ^^ Dfinity.prim_print env + | "decodeUTF8" -> + SR.UnboxedTuple 2, + compile_exp_vanilla env e ^^ + Text.prim_decodeUTF8 env | _ -> - SR.Unreachable, - todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) + (* Now try the binary prims, expecting a manifest tuple argument *) + begin match e.it with + | TupE [e1;e2] -> + begin + let compile_kernel_as sr inst = sr, compile_exp_as env sr e1 ^^ compile_exp_as env sr e2 ^^ inst + in match p with + | "Array.init" -> compile_kernel_as SR.Vanilla (Array.init env) + | "Array.tabulate" -> compile_kernel_as SR.Vanilla (Array.tabulate env) + | "shrs8" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.shrs_kernel Type.Word8) + | "shrs16" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.shrs_kernel Type.Word16) + | "shrs" -> compile_kernel_as SR.UnboxedWord32 (G.i (Binary (Wasm.Values.I32 I32Op.ShrS))) + | "shrs64" -> compile_kernel_as SR.UnboxedInt64 (G.i (Binary (Wasm.Values.I64 I64Op.ShrS))) + | "btst8" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.btst_kernel env Type.Word8) + | "btst16" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.btst_kernel env Type.Word16) + | "btst" -> compile_kernel_as SR.UnboxedWord32 (UnboxedSmallWord.btst_kernel env Type.Word32) + | "btst64" -> compile_kernel_as SR.UnboxedInt64 ( + let (set_b, get_b) = new_local64 env "b" + in set_b ^^ compile_const_64 1L ^^ get_b ^^ G.i (Binary (Wasm.Values.I64 I64Op.Shl)) ^^ + G.i (Binary (Wasm.Values.I64 I64Op.And))) + + | _ -> SR.Unreachable, todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) + end + | _ -> SR.Unreachable, todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) + end end | VarE var -> Var.get_val env var.it @@ -3473,6 +4238,7 @@ and compile_exp (env : E.t) exp = SR.unit, compile_exp_as env SR.bool e1 ^^ G.if_ (ValBlockType None) G.nop (G.i Unreachable) + | UnE (_, Syntax.PosOp, e1) -> compile_exp env e1 | UnE (t, op, e1) -> let sr, code = compile_unop env t op in sr, @@ -3508,7 +4274,7 @@ and compile_exp (env : E.t) exp = (* The value here can come from many places -- the expression, or any of the nested returns. Hard to tell which is the best stack representation here. - So let’s go with Vanialla. *) + So let’s go with Vanilla. *) SR.Vanilla, G.block_ (StackRep.to_block_type env SR.Vanilla) ( G.with_current_depth (fun depth -> @@ -3521,28 +4287,12 @@ and compile_exp (env : E.t) exp = SR.Unreachable, compile_exp_vanilla env e ^^ G.branch_to_ d - | LoopE (e, None) -> + | LoopE e -> SR.Unreachable, G.loop_ (ValBlockType None) (compile_exp_unit env e ^^ G.i (Br (nr 0l)) ) ^^ G.i Unreachable - | LoopE (e1, Some e2) -> - SR.unit, - G.loop_ (ValBlockType None) ( - compile_exp_unit env e1 ^^ - compile_exp_as env SR.bool e2 ^^ - G.if_ (ValBlockType None) (G.i (Br (nr 1l))) G.nop - ) - | WhileE (e1, e2) -> - SR.unit, - G.loop_ (ValBlockType None) ( - compile_exp_as env SR.bool e1 ^^ - G.if_ (ValBlockType None) ( - compile_exp_unit env e2 ^^ - G.i (Br (nr 1l)) - ) G.nop - ) | RetE e -> SR.Unreachable, compile_exp_as env (StackRep.of_arity (E.get_n_res env)) e ^^ @@ -3580,8 +4330,7 @@ and compile_exp (env : E.t) exp = let (set_funcref, get_funcref) = new_local env "funcref" in code1 ^^ StackRep.adjust env fun_sr SR.UnboxedReference ^^ set_funcref ^^ - compile_exp_as env (StackRep.of_arity cc.Value.n_args) e2 ^^ - Serialization.serialize_n env cc.Value.n_args ^^ + compile_exp_as env (StackRep.refs_of_arity cc.Value.n_args) e2 ^^ FuncDec.call_funcref env cc get_funcref end | SwitchE (e, cs) -> @@ -3602,53 +4351,22 @@ and compile_exp (env : E.t) exp = in let code2 = go env cs in code1 ^^ set_i ^^ orTrap code2 ^^ get_j - | ForE (p, e1, e2) -> - SR.unit, - let code1 = compile_exp_vanilla env e1 in - let (env1, code2) = compile_mono_pat env p in - let code3 = compile_exp_unit env1 e2 in - - let (set_i, get_i) = new_local env "iter" in - (* Store the iterator *) - code1 ^^ - set_i ^^ - - G.loop_ (ValBlockType None) ( - get_i ^^ - Object.load_idx_immut env1 (nr_ (Name "next")) ^^ - get_i ^^ - Object.load_idx_immut env1 (nr_ (Name "next")) ^^ - Closure.call_closure env1 (Value.local_cc 0 1) ^^ - let (set_oi, get_oi) = new_local env "opt" in - set_oi ^^ - - (* Check for null *) - get_oi ^^ - Opt.null ^^ - G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ - G.if_ (ValBlockType None) - G.nop - ( get_oi ^^ Opt.project ^^ - code2 ^^ code3 ^^ G.i (Br (nr 1l)) - ) - ) (* Async-wait lowering support features *) | DeclareE (name, _, e) -> let (env1, i) = E.add_local_with_offset env name.it 1l in let sr, code = compile_exp env1 e in sr, - Tagged.obj env Tagged.MutBox [ compile_unboxed_const 0l ] ^^ + Tagged.obj env Tagged.MutBox [ compile_unboxed_zero ] ^^ G.i (LocalSet (nr i)) ^^ code | DefineE (name, _, e) -> SR.unit, compile_exp_vanilla env e ^^ Var.set_val env name.it - | FuncE (x, cc, typ_binds, p, _rt, e) -> - let captured = Freevars.captured p e in - let mk_pat env1 = compile_func_pat env1 cc p in + | FuncE (x, cc, typ_binds, args, _rt, e) -> + let captured = Freevars.captured exp in let mk_body env1 = compile_exp_as env1 (StackRep.of_arity cc.Value.n_res) e in - FuncDec.lit env typ_binds x cc captured mk_pat mk_body exp.at + FuncDec.lit env typ_binds x cc captured args mk_body exp.at | ActorE (i, ds, fs, _) -> SR.UnboxedReference, let captured = Freevars.exp exp in @@ -3668,8 +4386,20 @@ and compile_exp (env : E.t) exp = and compile_exp_as env sr_out e = G.with_region e.at ( - let sr_in, code = compile_exp env e in - code ^^ StackRep.adjust env sr_in sr_out + match sr_out, e.it with + (* Some optimizations for certain sr_out and expressions *) + | SR.UnboxedRefTuple n, TupE es when n = List.length es -> + G.concat_map (fun e -> + compile_exp_as env SR.UnboxedReference e + ) es + | _ , BlockE (decs, exp) -> + let (env', code1) = compile_decs env decs in + let code2 = compile_exp_as env' sr_out exp in + code1 ^^ code2 + (* Fallback to whatever stackrep compile_exp chooses *) + | _ -> + let sr_in, code = compile_exp env e in + code ^^ StackRep.adjust env sr_in sr_out ) and compile_exp_as_opt env sr_out_o e = @@ -3690,7 +4420,7 @@ and compile_exp_unit (env : E.t) exp = (* The compilation of declarations (and patterns!) needs to handle mutual recursion. -This requires conceptually thre passes: +This requires conceptually three passes: 1. First we need to collect all names bound in a block, and find locations for then (which extends the environment). The environment is extended monotonously: The type-checker ensures that @@ -3805,11 +4535,6 @@ and compile_pat_local env pat : E.t * patternCode = let fill_code = fill_pat env1 pat in (env1, fill_code) -(* Used for mono patterns (ForE) *) -and compile_mono_pat env pat = - let (env1, fill_code) = compile_pat_local env pat in - (env1, orTrap fill_code) - (* Used for let patterns: If the patterns is an n-ary tuple pattern, we want to compile the expression accordingly, to avoid the reboxing. *) @@ -3842,35 +4567,6 @@ and compile_n_ary_pat env how pat = orTrap (fill_pat env1 pat) in (env1, alloc_code, arity, fill_code) -(* Used for function patterns - The complication is that functions are n-ary, and we get the elements - separately. - If the function is unary, that’s great. - If the pattern is a tuple pattern, that is great as well. - But if not, we need to construct the tuple first. -*) -and compile_func_pat env cc pat = - let env1 = alloc_pat_local env pat in - let fill_code get = - G.with_region pat.at @@ - if cc.Value.n_args = 1 - then - (* Easy case: unary *) - get 0 ^^ orTrap (fill_pat env1 pat) - else - match pat.it with - (* Another easy case: Nothing to match *) - | WildP -> G.nop - (* The good case: We have a tuple pattern *) - | TupP ps -> - assert (List.length ps = cc.Value.n_args); - G.concat_mapi (fun i p -> get i ^^ orTrap (fill_pat env1 p)) ps - (* The general case: Construct the tuple, and apply the full pattern *) - | _ -> - Array.lit env (Lib.List.table cc.Value.n_args (fun i -> get i)) ^^ - orTrap (fill_pat env1 pat) in - (env1, fill_code) - and compile_dec pre_env how dec : E.t * G.t * (E.t -> G.t) = (fun (pre_env,alloc_code,mk_code) -> (pre_env, G.with_region dec.at alloc_code, fun env -> @@ -3881,7 +4577,7 @@ and compile_dec pre_env how dec : E.t * G.t * (E.t -> G.t) = (* A special case for static expressions *) | LetD ({it = VarP v; _}, e) when not (AllocHow.M.mem v.it how) -> let (static_thing, fill) = compile_static_exp pre_env how e in - let d = StackRep.deferred_of_static_think pre_env static_thing in + let d = StackRep.deferred_of_static_thing pre_env static_thing in let pre_env1 = E.add_local_deferred pre_env v.it d in ( pre_env1, G.nop, fun env -> fill env; G.nop) | LetD (p, e) -> @@ -3924,11 +4620,10 @@ and compile_prog env (ds, e) = (env', code1 ^^ code2 ^^ StackRep.drop env' sr) and compile_static_exp env how exp = match exp.it with - | FuncE (name, cc, typ_binds, p, _rt, e) -> + | FuncE (name, cc, typ_binds, args, _rt, e) -> (* Get captured variables *) - let mk_pat env1 = compile_func_pat env1 cc p in let mk_body env1 = compile_exp_as env1 (StackRep.of_arity cc.Value.n_res) e in - FuncDec.closed env cc name mk_pat mk_body exp.at + FuncDec.closed env cc name args mk_body exp.at | _ -> assert false and compile_prelude env = @@ -3955,6 +4650,11 @@ and compile_start_func env (progs : Ir.prog list) : E.func_with_names = Func.of_body env [] [] (fun env1 -> let rec go env = function | [] -> G.nop + (* If the last program ends with an actor, then consider this the current actor *) + | [((decls, {it = ActorE (i, ds, fs, _); _}), _flavor)] -> + let (env', code1) = compile_decs env decls in + let code2 = main_actor env' i ds fs in + code1 ^^ code2 | ((prog, _flavor) :: progs) -> let (env1, code1) = compile_prog env prog in let code2 = go env1 progs in @@ -3986,14 +4686,20 @@ and fill_actor_fields env fs = and export_actor_field env ((f : Ir.field), ptr) = let Name name = f.it.name.it in let (fi, fill) = E.reserve_fun env name in - let cc = Value.call_conv_of_typ f.note in - E.add_dfinity_type env (fi, Lib.List.make cc.Value.n_args CustomSections.ElemBuf); + let _, _, _, ts, _ = Type.as_func f.note in + E.add_dfinity_type env (fi, + List.map ( + fun t -> Serialization.dfinity_type (Type.as_serialized t) + ) ts + ); E.add_export env (nr { name = Dfinity.explode name; edesc = nr (FuncExport (nr fi)) }); + let cc = Value.call_conv_of_typ f.note in fill (FuncDec.compile_static_message env cc ptr); +(* Local actor *) and actor_lit outer_env this ds fs at = if E.mode outer_env <> DfinityMode then G.i Unreachable else @@ -4001,6 +4707,7 @@ and actor_lit outer_env this ds fs at = let env = E.mk_global (E.mode outer_env) (E.get_prelude outer_env) ClosureTable.table_end in if E.mode env = DfinityMode then Dfinity.system_imports env; + Text.common_funcs env; Array.common_funcs env; (* Allocate static positions for exported functions *) @@ -4035,6 +4742,26 @@ and actor_lit outer_env this ds fs at = G.i (Call (nr (Dfinity.module_new_i outer_env))) ^^ G.i (Call (nr (Dfinity.actor_new_i outer_env))) +(* Main actor: Just return the initialization code, and export functions as needed *) +and main_actor env this ds fs = + if E.mode env <> DfinityMode then G.i Unreachable else + + (* Allocate static positions for exported functions *) + let located_ids = allocate_actor_fields env fs in + + List.iter (export_actor_field env) located_ids; + + (* Add this pointer *) + let env2 = E.add_local_deferred_vanilla env this.it Dfinity.get_self_reference in + + (* Compile the declarations *) + let (env3, decls_code) = compile_decs env2 ds in + + (* fill the static export references *) + let fill_code = fill_actor_fields env3 located_ids in + + decls_code ^^ fill_code + and actor_fake_object_idx env name = Dfinity.compile_databuf_of_bytes env (name.it) ^^ G.i (Call (nr (Dfinity.actor_export_i env))) @@ -4117,6 +4844,7 @@ let compile mode module_name (prelude : Ir.prog) (progs : Ir.prog list) : extend let env = E.mk_global mode prelude ClosureTable.table_end in if E.mode env = DfinityMode then Dfinity.system_imports env; + Text.common_funcs env; Array.common_funcs env; let start_fun = compile_start_func env (prelude :: progs) in diff --git a/src/con.ml b/src/con.ml index cf51891d324..376cb46a92a 100644 --- a/src/con.ml +++ b/src/con.ml @@ -18,11 +18,7 @@ module Stamps = Env.Make(String) let stamps : int Stamps.t ref = ref Stamps.empty let fresh_stamp name = - let n = - match Stamps.find_opt name !stamps with - | Some n -> n - | None -> 0 - in + let n = Lib.Option.get (Stamps.find_opt name !stamps) 0 in stamps := Stamps.add name (n + 1) !stamps; n diff --git a/src/construct.ml b/src/construct.ml index 567dc8a18b9..f43ca47c724 100644 --- a/src/construct.ml +++ b/src/construct.ml @@ -33,23 +33,34 @@ let id_of_exp x = | VarE x -> x | _ -> failwith "Impossible: id_of_exp" +let arg_of_exp x = + match x.it with + | VarE i -> { i with note = x.note.note_typ } + | _ -> failwith "Impossible: arg_of_exp" + +let exp_of_arg a = idE {a with note = () } a.note + (* Fresh id generation *) -let id_stamp = ref 0 +module Stamps = Map.Make(String) +let id_stamps = ref Stamps.empty -let fresh () = - let name = Printf.sprintf "$%i" (!id_stamp) in - id_stamp := !id_stamp + 1; - name +let fresh name_base () = + let n = Lib.Option.get (Stamps.find_opt name_base !id_stamps) 0 in + id_stamps := Stamps.add name_base (n + 1) !id_stamps; + Printf.sprintf "$%s/%i" name_base n -let fresh_id () = - let name = fresh () in +let fresh_id name_base () = + let name = fresh name_base () in name @@ no_region -let fresh_var typ = - let name = fresh () in +let fresh_var name_base typ = + let name = fresh name_base () in idE (name @@ no_region) typ +let fresh_vars name_base ts = + List.mapi (fun i t -> fresh_var (Printf.sprintf "%s%i" name_base i) t) ts + (* Patterns *) @@ -99,18 +110,24 @@ let dec_eff dec = match dec.it with | TypD _ -> T.Triv | LetD (_,e) | VarD (_,e) -> eff e +let is_useful_dec dec = match dec.it with + | LetD ({it = WildP;_}, {it = TupE [];_}) -> false + | LetD ({it = TupP [];_}, {it = TupE [];_}) -> false + | _ -> true + let blockE decs exp = - match decs with + let decs' = List.filter is_useful_dec decs in + match decs' with | [] -> exp | _ -> - let es = List.map dec_eff decs in - let typ = typ exp in - let e = List.fold_left max_eff (eff exp) es in - { it = BlockE (decs, exp); - at = no_region; - note = {S.note_typ = typ; - S.note_eff = e } - } + let es = List.map dec_eff decs' in + let typ = typ exp in + let e = List.fold_left max_eff (eff exp) es in + { it = BlockE (decs', exp); + at = no_region; + note = {S.note_typ = typ; + S.note_eff = e } + } let textE s = { it = LitE (S.TextLit s); @@ -134,10 +151,13 @@ let boolE b = S.note_eff = T.Triv} } -let callE exp1 ts exp2 t = +let callE exp1 ts exp2 = + let ret_ty = match T.promote (typ exp1) with + | T.Func (_, _, tbs, _, ts2) -> T.open_ ts (T.seq ts2) + | _ -> assert false in { it = CallE (Value.call_conv_of_typ (typ exp1), exp1, ts, exp2); at = no_region; - note = { S.note_typ = t; + note = { S.note_typ = ret_ty; S.note_eff = max_eff (eff exp1) (eff exp2) } } @@ -226,14 +246,12 @@ let labelE l typ exp = S.note_typ = typ } } -let loopE exp1 exp2Opt = - { it = LoopE (exp1, exp2Opt); +(* Used to desugar for loops, while loops and loop-while loops. *) +let loopE exp = + { it = LoopE exp; at = no_region; - note = { S.note_eff = Effect.max_eff (eff exp1) - (match exp2Opt with - | Some exp2 -> eff exp2 - | None -> Type.Triv); - S.note_typ = Type.Non } + note = { S.note_eff = eff exp ; + S.note_typ = T.Non } } let declare_idE x typ exp1 = @@ -270,30 +288,41 @@ let expD exp = let pat = { it = WildP; at = exp.at; note = exp.note.note_typ } in LetD (pat, exp) @@ exp.at +(* Derived expressions *) + +let letE x exp1 exp2 = blockE [letD x exp1] exp2 + +let thenE exp1 exp2 = blockE [expD exp1] exp2 + let ignoreE exp = if typ exp = T.unit then exp - else blockE [expD exp] (tupE []) - + else thenE exp (tupE []) -(* let expressions (derived) *) - -let letE x exp1 exp2 = blockE [letD x exp1] exp2 (* Mono-morphic function expression *) let funcE name t x exp = - let retty = match t with - | T.Func(_, _, _, _, ts2) -> T.seq ts2 + let arg_tys, retty = match t with + | T.Func(_, _, _, ts1, ts2) -> ts1, T.seq ts2 | _ -> assert false in let cc = Value.call_conv_of_typ t in + let args, exp' = + if cc.Value.n_args = 1; + then + [ arg_of_exp x ], exp + else + let vs = fresh_vars "param" arg_tys in + List.map arg_of_exp vs, + blockE [letD x (tupE vs)] exp + in ({it = FuncE ( name, cc, [], - varP x, + args, (* TODO: Assert invariant: retty has no free (unbound) DeBruijn indices -- Claudio *) retty, - exp + exp' ); at = no_region; note = { S.note_eff = T.Triv; S.note_typ = t } @@ -304,11 +333,12 @@ let nary_funcE name t xs exp = | T.Func(_, _, _, _, ts2) -> T.seq ts2 | _ -> assert false in let cc = Value.call_conv_of_typ t in + assert (cc.Value.n_args = List.length xs); ({it = FuncE ( name, cc, [], - seqP (List.map varP xs), + List.map arg_of_exp xs, retty, exp ); @@ -338,7 +368,7 @@ let answerT = T.unit let contT typ = T.Func (T.Local, T.Returns, [], T.as_seq typ, []) let cpsT typ = T.Func (T.Local, T.Returns, [], [contT typ], []) -let fresh_cont typ = fresh_var (contT typ) +let fresh_cont typ = fresh_var "cont" (contT typ) (* Sequence expressions *) @@ -400,3 +430,65 @@ let prim_async typ = let prim_await typ = primE "@await" (T.Func (T.Local, T.Returns, [], [T.Async typ; contT typ], [])) + +(* derived loop forms; each can be expressed as an unconditional loop *) + +let whileE exp1 exp2 = + (* while e1 e2 + ~~> label l loop { + if e1 then { e2 } else { break l } + } + *) + let lab = fresh_id "done" () in + labelE lab T.unit ( + loopE ( + ifE exp1 + exp2 + (breakE lab (tupE [])) + T.unit + ) + ) + +let loopWhileE exp1 exp2 = + (* loop e1 while e2 + ~~> label l loop { + let () = e1 ; + if e2 { } else { break l } + } + *) + let lab = fresh_id "done" () in + labelE lab T.unit ( + loopE ( + thenE exp1 + ( ifE exp2 + (tupE []) + (breakE lab (tupE [])) + T.unit + ) + ) + ) + +let forE pat exp1 exp2 = + (* for p in e1 e2 + ~~> + let nxt = e1.next ; + label l loop { + switch nxt () { + case null { break l }; + case p { e2 }; + } + } *) + let lab = fresh_id "done" () in + let ty1 = exp1.note.S.note_typ in + let _, tfs = Type.as_obj_sub "next" ty1 in + let tnxt = T.lookup_field "next" tfs in + let nxt = fresh_var "nxt" tnxt in + letE nxt (dotE exp1 (nameN "next") tnxt) ( + labelE lab Type.unit ( + loopE ( + switch_optE (callE nxt [] (tupE [])) + (breakE lab (tupE [])) + pat exp2 Type.unit + ) + ) + ) diff --git a/src/construct.mli b/src/construct.mli index 1ee80960918..9c81a16d622 100644 --- a/src/construct.mli +++ b/src/construct.mli @@ -1,4 +1,4 @@ -open Ir +open Ir open Type (* A miscellany of helpers to construct typed terms from typed terms *) @@ -23,11 +23,14 @@ val nextN : name (* Identifiers *) -val fresh_id : unit -> id -val fresh_var : typ -> var +val fresh_id : string -> unit -> id +val fresh_var : string -> typ -> var +val fresh_vars : string -> typ list -> var list val idE : id -> typ -> exp -val id_of_exp : exp -> id +val id_of_exp : var -> id +val arg_of_exp : var -> arg +val exp_of_arg : arg -> var (* Patterns *) @@ -49,7 +52,7 @@ val ignoreE : exp -> exp val unitE : exp val boolE : bool -> exp -val callE : exp -> typ list -> exp -> typ -> exp +val callE : exp -> typ list -> exp -> exp val ifE : exp -> exp -> exp -> typ -> exp val dotE : exp -> name -> typ -> exp @@ -60,7 +63,10 @@ val retE: exp -> exp val immuteE: exp -> exp val assignE : exp -> exp -> exp val labelE : id -> typ -> exp -> exp -val loopE : exp -> exp option -> exp +val loopE : exp -> exp +val forE : pat -> exp -> exp -> exp +val loopWhileE : exp -> exp -> exp +val whileE : exp -> exp -> exp val declare_idE : id -> typ -> exp -> exp val define_idE : id -> mut -> exp -> exp diff --git a/src/coverage.ml b/src/coverage.ml index e70a5ae001b..6447ca60e75 100644 --- a/src/coverage.ml +++ b/src/coverage.ml @@ -178,7 +178,7 @@ let warn at fmt = ) fmt let check_cases cases t : bool = - let sets = make_sets () in + let sets = make_sets () in let exhaustive = fail (InCase (Source.no_region, cases, t)) Any sets in let unreached_cases = AtSet.diff sets.cases sets.reached_cases in let unreached_alts = AtSet.diff sets.alts sets.reached_alts in diff --git a/src/customSections.ml b/src/customSections.ml index b21f86bee6d..93094f0038a 100644 --- a/src/customSections.ml +++ b/src/customSections.ml @@ -1,6 +1,6 @@ (* Some data type to represent custom sectoins *) -type type_ = I32 | DataBuf | ElemBuf +type type_ = I32 | DataBuf | ElemBuf | ActorRef (* Some Code copied from encodeMap.ml *) type stream = @@ -77,9 +77,11 @@ let encode (fun _ (li, x) -> vu32 li; f x) in let ty = function - | I32 -> vu32 0x7fl - | DataBuf -> vu32 0x6cl - | ElemBuf -> vu32 0x6bl in + | I32 -> vu32 0x7fl + | DataBuf -> vu32 0x6cl + | ElemBuf -> vu32 0x6bl + | ActorRef -> vu32 0x6fl + in section 0 (fun _ -> string "types"; diff --git a/src/desugar.ml b/src/desugar.ml index dbdfc8347d8..1004e84a99d 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -56,7 +56,8 @@ and exp' at note = function | S.IdxE (e1, e2) -> I.IdxE (exp e1, exp e2) | S.FuncE (name, s, tbs, p, ty, e) -> let cc = Value.call_conv_of_typ note.S.note_typ in - I.FuncE (name, cc, typ_binds tbs, param p, ty.note, exp e) + let args, wrap = to_args cc p in + I.FuncE (name, cc, typ_binds tbs, args, ty.note, wrap (exp e)) | S.CallE (e1, inst, e2) -> let cc = Value.call_conv_of_typ e1.Source.note.S.note_typ in let inst = List.map (fun t -> t.Source.note) inst in @@ -69,10 +70,10 @@ and exp' at note = function | S.OrE (e1, e2) -> I.IfE (exp e1, trueE, exp e2) | S.IfE (e1, e2, e3) -> I.IfE (exp e1, exp e2, exp e3) | S.SwitchE (e1, cs) -> I.SwitchE (exp e1, cases cs) - | S.WhileE (e1, e2) -> I.WhileE (exp e1, exp e2) - | S.LoopE (e1, None) -> I.LoopE (exp e1, None) - | S.LoopE (e1, Some e2) -> I.LoopE (exp e1, Some (exp e2)) - | S.ForE (p, e1, e2) -> I.ForE (pat p, exp e1, exp e2) + | S.WhileE (e1, e2) -> (whileE (exp e1) (exp e2)).it + | S.LoopE (e1, None) -> I.LoopE (exp e1) + | S.LoopE (e1, Some e2) -> (loopWhileE (exp e1) (exp e2)).it + | S.ForE (p, e1, e2) -> (forE (pat p) (exp e1) (exp e2)).it | S.LabelE (l, t, e) -> I.LabelE (l, t.Source.note, exp e) | S.BreakE (l, e) -> I.BreakE (l, exp e) | S.RetE e -> I.RetE (exp e) @@ -136,7 +137,7 @@ and block force_unit ds = | false, S.LetD ({it = S.VarP x; _}, e) -> (extra @ List.map dec ds, idE x e.note.S.note_typ) | false, S.LetD (p', e') -> - let x = fresh_var (e'.note.S.note_typ) in + let x = fresh_var "x" (e'.note.S.note_typ) in (extra @ List.map dec prefix @ [letD x (exp e'); letP (pat p') x], x) | _, _ -> (extra @ List.map dec ds, tupE []) @@ -156,12 +157,6 @@ and decs ds = extra_typDs ds @ List.map dec ds and dec d = { (phrase' dec' d) with note = () } -and param p = - pat (match p.it, p.note with - | S.ParP p1, _ -> p1 - | S.TupP [p1], Type.Tup [n] -> { p with it = p1.it; note = n } - | _ -> p) - and dec' at n d = match d with | S.ExpD e -> (expD (exp e)).it | S.LetD (p, e) -> @@ -195,8 +190,9 @@ and dec' at n d = match d with | _ -> assert false in let varPat = {it = I.VarP id'; at = at; note = fun_typ } in + let args, wrap = to_args cc p in let fn = { - it = I.FuncE (id.it, cc, typ_binds tbs, param p, obj_typ, + it = I.FuncE (id.it, cc, typ_binds tbs, args, obj_typ, wrap { it = obj at s (Some self_id) es obj_typ; at = at; note = { S.note_typ = obj_typ; S.note_eff = T.Triv } }); @@ -226,6 +222,58 @@ and pat' = function | S.AnnotP (p, _) | S.ParP p -> pat' p.it +and to_arg p : (Ir.arg * (Ir.exp -> Ir.exp)) = + match p.it with + | S.AnnotP (p, _) -> to_arg p + | S.VarP i -> + { i with note = p.note }, + (fun e -> e) + | S.WildP -> + let v = fresh_var "param" p.note in + arg_of_exp v, + (fun e -> e) + | _ -> + let v = fresh_var "param" p.note in + arg_of_exp v, + (fun e -> blockE [letP (pat p) v] e) + + +and to_args cc p : (Ir.arg list * (Ir.exp -> Ir.exp)) = + let n = cc.Value.n_args in + let tys = if n = 1 then [p.note] else T.as_seq p.note in + + let args, wrap = + match n, p.it with + | _, S.WildP -> + let vs = fresh_vars "param" tys in + List.map arg_of_exp vs, + (fun e -> e) + | 1, _ -> + let a, wrap = to_arg p in + [a], wrap + | 0, S.TupP [] -> + [] , (fun e -> e) + | _, S.TupP ps -> + assert (List.length ps = n); + List.fold_right (fun p (args, wrap) -> + let (a, wrap1) = to_arg p in + (a::args, fun e -> wrap1 (wrap e)) + ) ps ([], (fun e -> e)) + | _, _ -> + let vs = fresh_vars "param" tys in + List.map arg_of_exp vs, + (fun e -> blockE [letP (pat p) (tupE vs)] e) + in + + let wrap_under_async e = + if cc.Value.sort = T.Sharable && cc.Value.control = T.Promises + then match e.it with + | Ir.AsyncE e' -> { e with it = Ir.AsyncE (wrap e') } + | _ -> assert false + else wrap e in + + args, wrap_under_async + and prog (p : Syntax.prog) : Ir.prog = begin match p.it with | [] -> ([], tupE []) @@ -233,6 +281,7 @@ and prog (p : Syntax.prog) : Ir.prog = end , { I.has_await = true ; I.has_async_typ = true + ; I.serialized = false } (* validation *) diff --git a/src/effect.ml b/src/effect.ml index 6f434dd9ef9..9d913ea50d7 100644 --- a/src/effect.ml +++ b/src/effect.ml @@ -130,16 +130,13 @@ module Ir = | LabelE (_, _, exp1) | BreakE (_, exp1) | RetE exp1 - | LoopE (exp1, None) -> + | LoopE exp1 -> effect_exp exp1 | BinE (_, exp1, _, exp2) | IdxE (exp1, exp2) | RelE (_, exp1, _, exp2) | AssignE (exp1, exp2) - | CallE (_, exp1, _, exp2) - | WhileE (exp1, exp2) - | LoopE (exp1, Some exp2) - | ForE (_, exp1, exp2) -> + | CallE (_, exp1, _, exp2) -> let t1 = effect_exp exp1 in let t2 = effect_exp exp2 in max_eff t1 t2 diff --git a/src/freevars.ml b/src/freevars.ml index 731dde8e39f..cb50db88142 100644 --- a/src/freevars.ml +++ b/src/freevars.ml @@ -76,10 +76,7 @@ let rec exp e : f = match e.it with | BlockE (ds, e1) -> close (decs ds +++ exp e1) | IfE (e1, e2, e3) -> exps [e1; e2; e3] | SwitchE (e, cs) -> exp e ++ cases cs - | WhileE (e1, e2) -> exps [e1; e2] - | LoopE (e1, None) -> exp e1 - | LoopE (e1, Some e2) -> exps [e1; e2] - | ForE (p, e1, e2) -> exp e1 ++ (exp e2 /// pat p) + | LoopE e1 -> exp e1 | LabelE (i, t, e) -> exp e | BreakE (i, e) -> exp e | RetE e -> exp e @@ -89,7 +86,7 @@ let rec exp e : f = match e.it with | OptE e -> exp e | DeclareE (i, t, e) -> exp e // i.it | DefineE (i, m, e) -> id i ++ exp e - | FuncE (x, cc, tp, p, t, e) -> under_lambda (exp e /// pat p) + | FuncE (x, cc, tp, as_, t, e) -> under_lambda (exp e /// args as_) | ActorE (i, ds, fs, _) -> close (decs ds +++ fields fs) // i.it | NewObjE (_, fs, _) -> fields fs @@ -97,6 +94,10 @@ and fields fs = unions (fun f -> id f.it.var) fs and exps es : f = unions exp es +and arg a : fd = (M.empty, S.singleton a.it) + +and args as_ : fd = union_binders arg as_ + and pat p : fd = match p.it with | WildP -> (M.empty, S.empty) | VarP i -> (M.empty, S.singleton i.it) @@ -119,7 +120,7 @@ and dec d = match d.it with | TypD c -> (M.empty, S.empty) (* The variables captured by a function. May include the function itself! *) -and captured p e = - List.map fst (M.bindings (exp e /// pat p)) +and captured e = + List.map fst (M.bindings (exp e)) and decs ps : fd = union_binders dec ps diff --git a/src/interpret_ir.ml b/src/interpret_ir.ml index 9cda67fe4c4..bded36590fc 100644 --- a/src/interpret_ir.ml +++ b/src/interpret_ir.ml @@ -352,44 +352,8 @@ and interpret_exp_mut env exp (k : V.value V.cont) = interpret_exp env exp1 (fun v1 -> interpret_cases env cases exp.at v1 k ) - | WhileE (exp1, exp2) -> - let k_continue = fun v -> V.as_unit v; interpret_exp env exp k in - interpret_exp env exp1 (fun v1 -> - if V.as_bool v1 - then interpret_exp env exp2 k_continue - else k V.unit - ) - | LoopE (exp1, None) -> + | LoopE exp1 -> interpret_exp env exp1 (fun v -> V.as_unit v; interpret_exp env exp k) - | LoopE (exp1, Some exp2) -> - interpret_exp env exp1 (fun v1 -> - V.as_unit v1; - interpret_exp env exp2 (fun v2 -> - if V.as_bool v2 - then interpret_exp env exp k - else k V.unit - ) - ) - | ForE (pat, exp1, exp2) -> - interpret_exp env exp1 (fun v1 -> - let fs = V.as_obj v1 in - let _, next = V.as_func (find "next" fs) in - let rec k_continue = fun v -> - V.as_unit v; - next V.unit (fun v' -> - match v' with - | V.Opt v1 -> - (match match_pat pat v1 with - | None -> - trap pat.at "value %s does not match pattern" (V.string_of_val v') - | Some ve -> - interpret_exp (adjoin_vals env ve) exp2 k_continue - ) - | V.Null -> k V.unit - | _ -> assert false - ) - in k_continue V.unit - ) | LabelE (id, _typ, exp1) -> let env' = {env with labs = V.Env.add id.it k env.labs} in interpret_exp env' exp1 k @@ -429,9 +393,9 @@ and interpret_exp_mut env exp (k : V.value V.cont) = define_id env id v'; k V.unit ) - | FuncE (x, cc, _typbinds, pat, _typ, exp) -> - let f = interpret_func env x pat - (fun env' -> interpret_exp env' exp) in + | FuncE (x, cc, _typbinds, args, _typ, e) -> + let f = interpret_func env exp.at x args + (fun env' -> interpret_exp env' e) in let v = V.Func (cc, f) in let v = match cc.Value.sort with @@ -476,6 +440,17 @@ and interpret_cases env cases at v (k : V.value V.cont) = | Some ve -> interpret_exp (adjoin_vals env ve) exp k | None -> interpret_cases env cases' at v k +(* Argument lists *) + +and match_arg a v : val_env = V.Env.singleton a.it (Lib.Promise.make_fulfilled v) + +and match_args at args v : val_env = + match args with + | [a] -> match_arg a v + | _ -> + let vs = V.as_tup v in + assert (List.length vs = List.length args); + List.fold_left V.Env.adjoin V.Env.empty (List.map2 match_arg args vs) (* Patterns *) @@ -539,10 +514,13 @@ and match_lit lit v : bool = | PreLit _, _ -> assert false | _ -> false +and match_id id v : val_env = + V.Env.singleton id.it (Lib.Promise.make_fulfilled v) + and match_pat pat v : val_env option = match pat.it with | WildP -> Some V.Env.empty - | VarP id -> Some (V.Env.singleton id.it (Lib.Promise.make_fulfilled v)) + | VarP id -> Some (match_id id v) | LitP lit -> if match_lit lit v then Some V.Env.empty @@ -612,26 +590,22 @@ and interpret_decs env decs (k : unit V.cont) = | [] -> k () | d::ds -> interpret_dec env d (fun () -> interpret_decs env ds k) -and interpret_func env x pat f v (k : V.value V.cont) = +and interpret_func env at x args f v (k : V.value V.cont) = if !Flags.trace then trace "%s%s" x (string_of_arg v); - match match_pat pat v with - | None -> - trap pat.at "argument value %s does not match parameter list" - (V.string_of_val v) - | Some ve -> - incr trace_depth; - let k' = fun v' -> - if !Flags.trace then trace "<= %s" (V.string_of_val v'); - decr trace_depth; - k v' - in - let env' = - { vals = V.Env.adjoin env.vals ve; - labs = V.Env.empty; - rets = Some k'; - async = false - } - in f env' k' + let ve = match_args at args v in + incr trace_depth; + let k' = fun v' -> + if !Flags.trace then trace "<= %s" (V.string_of_val v'); + decr trace_depth; + k v' + in + let env' = + { vals = V.Env.adjoin env.vals ve; + labs = V.Env.empty; + rets = Some k'; + async = false + } + in f env' k' (* Programs *) diff --git a/src/ir.ml b/src/ir.ml index 4dad57d9a8d..8d06eca98fa 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -23,6 +23,9 @@ and pat' = | OptP of pat (* option *) | AltP of pat * pat (* disjunctive *) +(* Like id, but with a type attached *) +type arg = (string, Type.typ) Source.annotated_phrase + (* Expressions *) type exp = exp' phrase @@ -46,9 +49,7 @@ and exp' = | BlockE of (dec list * exp) (* block *) | IfE of exp * exp * exp (* conditional *) | SwitchE of exp * case list (* switch *) - | WhileE of exp * exp (* while-do loop *) - | LoopE of exp * exp option (* do-while loop *) - | ForE of pat * exp * exp (* iteration *) + | LoopE of exp (* do-while loop *) | LabelE of id * Type.typ * exp (* label *) | BreakE of id * exp (* break *) | RetE of exp (* return *) @@ -58,7 +59,7 @@ and exp' = | DeclareE of id * Type.typ * exp (* local promise *) | DefineE of id * mut * exp (* promise fulfillment *) | FuncE of (* function *) - string * Value.call_conv * typ_bind list * pat * Type.typ * exp + string * Value.call_conv * typ_bind list * arg list * Type.typ * exp | ActorE of id * dec list * field list * Type.typ (* actor *) | NewObjE of Type.obj_sort * field list * Type.typ (* make an object *) @@ -94,6 +95,7 @@ should hold. type flavor = { has_async_typ : bool; (* AsyncT *) has_await : bool; (* AwaitE and AsyncE *) + serialized : bool; (* Shared function arguments are serialized *) } diff --git a/src/lexer.mll b/src/lexer.mll index b64030fe1a6..7f202103d7c 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -22,8 +22,15 @@ let error_nest start lexbuf msg = lexbuf.Lexing.lex_start_p <- start; error lexbuf msg -let unicode lexbuf s i = + +let utf8 s i = + let len = if s.[!i] < '\xe0' then 1 else if s.[!i] < '\xf0' then 2 else 3 in + i := !i + len; + List.hd (Utf8.decode (String.sub s (!i - len) (1 + len))) + +let codepoint lexbuf s i = let u = + if s.[!i] >= '\x80' then utf8 s i else if s.[!i] <> '\\' then Char.code s.[!i] else match (incr i; s.[!i]) with | 'n' -> Char.code '\n' @@ -45,13 +52,13 @@ let unicode lexbuf s i = in incr i; u let char lexbuf s = - unicode lexbuf s (ref 1) + codepoint lexbuf s (ref 1) let text lexbuf s = let b = Buffer.create (String.length s) in let i = ref 1 in while !i < String.length s - 1 do - let bs = Utf8.encode [unicode lexbuf s i] in + let bs = Utf8.encode [codepoint lexbuf s i] in Buffer.add_substring b bs 0 (String.length bs) done; Buffer.contents b diff --git a/src/parser.mly b/src/parser.mly index 7d494ce5a62..054ab737bff 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -146,10 +146,6 @@ seplist(X, SEP) : | x=X { [x] } | x=X SEP xs=seplist(X, SEP) { x::xs } -seplist1(X, SEP) : - | (* empty *) { [] } - | x=X SEP xs=seplist(X, SEP) { x::xs } - (* Basics *) @@ -201,10 +197,8 @@ typ_obj : { tfs } typ_nullary : - | LPAR t=typ RPAR - { ParT(t) @! at $loc } - | LPAR ts=seplist1(typ_item, COMMA) RPAR - { TupT(ts) @! at $sloc } + | LPAR ts=seplist(typ_item, COMMA) RPAR + { (match ts with [t] -> ParT(t) | _ -> TupT(ts)) @! at $sloc } | x=id tso=typ_args? { VarT(x, Lib.Option.get tso []) @! at $sloc } | LBRACKET m=var_opt t=typ RBRACKET @@ -337,10 +331,8 @@ exp_nullary : { VarE(x) @? at $sloc } | l=lit { LitE(ref l) @? at $sloc } - | LPAR e=exp RPAR - { e } - | LPAR es=seplist1(exp, COMMA) RPAR - { TupE(es) @? at $sloc } + | LPAR es=seplist(exp, COMMA) RPAR + { match es with [e] -> e | _ -> TupE(es) @? at $sloc } | PRIM s=TEXT { PrimE(s) @? at $sloc } @@ -482,13 +474,8 @@ pat_nullary : { VarP(x) @! at $sloc } | l=lit { LitP(ref l) @! at $sloc } - | LPAR p=pat RPAR - { match p.it with - | TupP _ -> ParP(p) @! at $sloc - | _ -> ParP(p) @! p.at - } - | LPAR ps=seplist1(pat_bin, COMMA) RPAR - { TupP(ps) @! at $sloc } + | LPAR ps=seplist(pat_bin, COMMA) RPAR + { (match ps with [p] -> ParP(p) | _ -> TupP(ps)) @! at $sloc } pat_un : | p=pat_nullary diff --git a/src/pipeline.ml b/src/pipeline.ml index eb59f78b963..cd920c83e51 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -52,9 +52,9 @@ let dump_prog flag prog = Wasm.Sexpr.print 80 (Arrange.prog prog) else () -let dump_ir flag prog = +let dump_ir flag prog_ir = if !flag then - Wasm.Sexpr.print 80 (Arrange_ir.prog prog) + Wasm.Sexpr.print 80 (Arrange_ir.prog prog_ir) else () let parse_with mode lexer parser name : parse_result = @@ -115,25 +115,31 @@ let check_prog infer senv name prog (* IR transforms *) -let transform_ir transform_name transform flag env prog name = - if flag then - begin - phase transform_name name; - let prog' : Ir.prog = transform env prog in - dump_ir Flags.dump_lowering prog'; - Check_ir.check_prog env transform_name prog'; - prog' - end +let transform transform_name trans env prog name = + phase transform_name name; + let prog_ir' : Ir.prog = trans env prog in + dump_ir Flags.dump_lowering prog_ir'; + Check_ir.check_prog env transform_name prog_ir'; + prog_ir' + +let transform_if transform_name trans flag env prog name = + if flag then transform transform_name trans env prog name else prog +let desugar = + transform "Desugaring" Desugar.transform + let await_lowering = - transform_ir "Await Lowering" (fun _ -> Await.transform) + transform_if "Await Lowering" (fun _ -> Await.transform) let async_lowering = - transform_ir "Async Lowering" Async.transform + transform_if "Async Lowering" Async.transform + +let serialization = + transform_if "Synthesizing serialization code" Serialization.transform let tailcall_optimization = - transform_ir "Tailcall optimization" (fun _ -> Tailcall.transform) + transform_if "Tailcall optimization" (fun _ -> Tailcall.transform) let check_with parse infer senv name : check_result = match parse name with @@ -147,10 +153,10 @@ let infer_prog_unit senv prog = (Typing.check_prog senv prog) let check_string senv s = check_with (parse_string s) Typing.infer_prog senv -let check_file senv n = check_with parse_file infer_prog_unit senv n +let check_file senv n = check_with parse_file Typing.infer_prog senv n let check_files senv = function | [n] -> check_file senv n - | ns -> check_with (fun _n -> parse_files ns) infer_prog_unit senv "all" + | ns -> check_with (fun _n -> parse_files ns) Typing.infer_prog senv "all" (* Interpretation *) @@ -164,10 +170,10 @@ let interpret_prog (senv,denv) name prog : (Value.value * Interpret.scope) optio let vo, scope = if !Flags.interpret_ir then - let prog_ir = Desugar.transform senv prog in - Check_ir.check_prog senv "desugaring" prog_ir; + let prog_ir = desugar senv prog name in let prog_ir = await_lowering (!Flags.await_lowering) senv prog_ir name in let prog_ir = async_lowering (!Flags.await_lowering && !Flags.async_lowering) senv prog_ir name in + let prog_ir = serialization (!Flags.await_lowering && !Flags.async_lowering) senv prog_ir name in let prog_ir = tailcall_optimization true senv prog_ir name in Interpret_ir.interpret_prog denv prog_ir else Interpret.interpret_prog denv prog in @@ -289,14 +295,14 @@ let compile_with check mode name : compile_result = | Error msgs -> Error msgs | Ok ((prog, _t, scope), msgs) -> Diag.print_messages msgs; - let prelude = Desugar.transform Typing.empty_scope prelude in - let prog = Desugar.transform initial_stat_env prog in - Check_ir.check_prog initial_stat_env "desugaring" prog; - let prog = await_lowering true initial_stat_env prog name in - let prog = async_lowering true initial_stat_env prog name in - let prog = tailcall_optimization true initial_stat_env prog name in + let prelude_ir = Desugar.transform Typing.empty_scope prelude in + let prog_ir = desugar initial_stat_env prog name in + let prog_ir = await_lowering true initial_stat_env prog_ir name in + let prog_ir = async_lowering true initial_stat_env prog_ir name in + let prog_ir = serialization true initial_stat_env prog_ir name in + let prog_ir = tailcall_optimization true initial_stat_env prog_ir name in phase "Compiling" name; - let module_ = Compile.compile mode name prelude [prog] in + let module_ = Compile.compile mode name prelude_ir [prog_ir] in Ok module_ let compile_string mode s name = diff --git a/src/prelude.ml b/src/prelude.ml index 298f76496e7..21db6583103 100644 --- a/src/prelude.ml +++ b/src/prelude.ml @@ -31,9 +31,16 @@ class revrange(x : Nat, y : Nat) { next() : ?Nat { if (i <= y) null else {i -= 1; ?i} }; }; +func charToText(c : Char) : Text = (prim "Char->Text" : Char -> Text) c; + func printInt(x : Int) { (prim "printInt" : Int -> ()) x }; +func printChar(x : Char) { print (charToText x) }; func print(x : Text) { (prim "print" : Text -> ()) x }; +// Hashing +func hashInt(n : Int) : Word32 = (prim "Int~hash" : Int -> Word32) n; + + // Conversions func natToWord8(n : Nat) : Word8 = (prim "Nat->Word8" : Nat -> Word8) n; func word8ToNat(n : Word8) : Nat = (prim "Word8->Nat" : Word8 -> Nat) n; @@ -50,6 +57,40 @@ func word32ToNat(n : Word32) : Nat = (prim "Word32->Nat" : Word32 -> Nat) n; func intToWord32(n : Int) : Word32 = (prim "Int->Word32" : Int -> Word32) n; func word32ToInt(n : Word32) : Int = (prim "Word32->Int" : Word32 -> Int) n; +func natToWord64(n : Nat) : Word64 = (prim "Nat->Word64" : Nat -> Word64) n; +func word64ToNat(n : Word64) : Nat = (prim "Word64->Nat" : Word64 -> Nat) n; +func intToWord64(n : Int) : Word64 = (prim "Int->Word64" : Int -> Word64) n; +func word64ToInt(n : Word64) : Int = (prim "Word64->Int" : Word64 -> Int) n; + +func charToWord32(c : Char) : Word32 = (prim "Char->Word32" : Char -> Word32) c; +func word32ToChar(w : Word32) : Char = (prim "Word32->Char" : Word32 -> Char) w; +func decodeUTF8(s : Text) : (Word32, Char) = (prim "decodeUTF8" : Text -> (Word32, Char)) s; + +// Exotic bitwise operations +func shrsWord8(w : Word8, amount : Word8) : Word8 = (prim "shrs8" : (Word8, Word8) -> Word8) (w, amount); +func popcntWord8(w : Word8) : Word8 = (prim "popcnt8" : Word8 -> Word8) w; +func clzWord8(w : Word8) : Word8 = (prim "clz8" : Word8 -> Word8) w; +func ctzWord8(w : Word8) : Word8 = (prim "ctz8" : Word8 -> Word8) w; +func btstWord8(w : Word8, amount : Word8) : Bool = (prim "btst8" : (Word8, Word8) -> Word8) (w, amount) != (0 : Word8); + +func shrsWord16(w : Word16, amount : Word16) : Word16 = (prim "shrs16" : (Word16, Word16) -> Word16) (w, amount); +func popcntWord16(w : Word16) : Word16 = (prim "popcnt16" : Word16 -> Word16) w; +func clzWord16(w : Word16) : Word16 = (prim "clz16" : Word16 -> Word16) w; +func ctzWord16(w : Word16) : Word16 = (prim "ctz16" : Word16 -> Word16) w; +func btstWord16(w : Word16, amount : Word16) : Bool = (prim "btst16" : (Word16, Word16) -> Word16) (w, amount) != (0 : Word16); + +func shrsWord32(w : Word32, amount : Word32) : Word32 = (prim "shrs" : (Word32, Word32) -> Word32) (w, amount); +func popcntWord32(w : Word32) : Word32 = (prim "popcnt" : Word32 -> Word32) w; +func clzWord32(w : Word32) : Word32 = (prim "clz" : Word32 -> Word32) w; +func ctzWord32(w : Word32) : Word32 = (prim "ctz" : Word32 -> Word32) w; +func btstWord32(w : Word32, amount : Word32) : Bool = (prim "btst" : (Word32, Word32) -> Word32) (w, amount) != (0 : Word32); + +func shrsWord64(w : Word64, amount : Word64) : Word64 = (prim "shrs64" : (Word64, Word64) -> Word64) (w, amount); +func popcntWord64(w : Word64) : Word64 = (prim "popcnt64" : Word64 -> Word64) w; +func clzWord64(w : Word64) : Word64 = (prim "clz64" : Word64 -> Word64) w; +func ctzWord64(w : Word64) : Word64 = (prim "ctz64" : Word64 -> Word64) w; +func btstWord64(w : Word64, amount : Word64) : Bool = (prim "btst64" : (Word64, Word64) -> Word64) (w, amount) != (0 : Word64); + // This would be nicer as a objects, but lets do them as functions // until the compiler has a concept of “static objects” @@ -105,6 +146,10 @@ end (* Conv *) let prim = function | "abs" -> fun v k -> k (Int (Nat.abs (as_int v))) + | "Int~hash" -> fun v k -> + let i = Word64.of_int_s (Big_int.int_of_big_int (as_int v)) in + let j = Word64.(and_ 0xFFFFFFFFL (xor (shr_u i 32L) i)) + in k (Word32 (Word32.of_int_u (Int64.to_int j))) | "Nat->Word8" -> fun v k -> let i = Big_int.int_of_big_int (as_int v) in k (Word8 (Word8.of_int_u i)) @@ -124,6 +169,13 @@ let prim = function let i = Big_int.int_of_big_int (as_int v) in k (Word32 (Word32.of_int_s i)) + | "Nat->Word64" -> fun v k -> + let i = Big_int.int_of_big_int (as_int v) + in k (Word64 (Word64.of_int_u i)) + | "Int->Word64" -> fun v k -> + let i = Big_int.int_of_big_int (as_int v) + in k (Word64 (Word64.of_int_s i)) + | "Word8->Nat" -> fun v k -> let i = Int32.to_int (Int32.shift_right_logical (Word8.to_bits (as_word8 v)) 24) in k (Int (Big_int.big_int_of_int i)) @@ -141,8 +193,92 @@ let prim = function in k (Int (Big_int.big_int_of_int i)) | "Word32->Int" -> fun v k -> k (Int (Big_int.big_int_of_int32 (as_word32 v))) + | "Word64->Nat" -> fun v k -> + let i = Int64.to_int (as_word64 v) (* ! *) + in k (Int (Big_int.big_int_of_int i)) + | "Word64->Int" -> fun v k -> k (Int (Big_int.big_int_of_int64 (as_word64 v))) + + | "Char->Word32" -> fun v k -> + let i = as_char v + in k (Word32 (Word32.of_int_u i)) + | "Word32->Char" -> fun v k -> + let i = Conv.of_signed_Word32 (as_word32 v) + in k (Char i) + | "shrs8" + | "shrs16" + | "shrs" + | "shrs64" -> fun v k -> + let w, a = as_pair v + in k (match w with + | Word8 y -> Word8 (Word8 .shr_s y (as_word8 a)) + | Word16 y -> Word16 (Word16.shr_s y (as_word16 a)) + | Word32 y -> Word32 (Word32.shr_s y (as_word32 a)) + | Word64 y -> Word64 (Word64.shr_s y (as_word64 a)) + | _ -> failwith "shrs") + | "popcnt8" + | "popcnt16" + | "popcnt" + | "popcnt64" -> fun v k -> + k (match v with + | Word8 w -> Word8 (Word8. popcnt w) + | Word16 w -> Word16 (Word16.popcnt w) + | Word32 w -> Word32 (Word32.popcnt w) + | Word64 w -> Word64 (Word64.popcnt w) + | _ -> failwith "popcnt") + | "clz8" + | "clz16" + | "clz" + | "clz64" -> fun v k -> + k (match v with + | Word8 w -> Word8 (Word8. clz w) + | Word16 w -> Word16 (Word16.clz w) + | Word32 w -> Word32 (Word32.clz w) + | Word64 w -> Word64 (Word64.clz w) + | _ -> failwith "clz") + | "ctz8" + | "ctz16" + | "ctz" + | "ctz64" -> fun v k -> + k (match v with + | Word8 w -> Word8 (Word8. ctz w) + | Word16 w -> Word16 (Word16.ctz w) + | Word32 w -> Word32 (Word32.ctz w) + | Word64 w -> Word64 (Word64.ctz w) + | _ -> failwith "ctz") + + | "btst8" + | "btst16" + | "btst" + | "btst64" -> fun v k -> + let w, a = as_pair v + in k (match w with + | Word8 y -> Word8 Word8.(and_ y (shl (of_int_u 1) (as_word8 a))) + | Word16 y -> Word16 Word16.(and_ y (shl (of_int_u 1) (as_word16 a))) + | Word32 y -> Word32 (Word32.and_ y (Word32.shl 1l (as_word32 a))) + | Word64 y -> Word64 (Word64.and_ y (Word64.shl 1L (as_word64 a))) + | _ -> failwith "btst") + + | "Char->Text" -> fun v k -> let str = match as_char v with + | c when c <= 0o177 -> String.make 1 (Char.chr c) + | code -> Wasm.Utf8.encode [code] + in k (Text str) | "print" -> fun v k -> Printf.printf "%s%!" (as_text v); k unit | "printInt" -> fun v k -> Printf.printf "%d%!" (Int.to_int (as_int v)); k unit + | "decodeUTF8" -> fun v k -> + let s = as_text v in + let take_and_mask bits offset = Int32.(logand (sub (shift_left 1l bits) 1l) (of_int (Char.code s.[offset]))) in + let classify_utf8_leader = + Int32.(function + | ch when logand ch (lognot 0b01111111l) = 0b00000000l -> [take_and_mask 7] + | ch when logand ch (lognot 0b00011111l) = 0b11000000l -> [take_and_mask 5; take_and_mask 6] + | ch when logand ch (lognot 0b00001111l) = 0b11100000l -> [take_and_mask 4; take_and_mask 6; take_and_mask 6] + | ch when logand ch (lognot 0b00000111l) = 0b11110000l -> [take_and_mask 3; take_and_mask 6; take_and_mask 6; take_and_mask 6] + | _ -> failwith "decodeUTF8") in + let nobbles = List.mapi (fun i f -> f i) (classify_utf8_leader (Int32.of_int (Char.code s.[0]))) in + let code = List.fold_left Int32.(fun acc nobble -> logor (shift_left acc 6) nobble) 0l nobbles + in k (Tup [Word32 (Int32.of_int (List.length nobbles)); Char (Int32.to_int code)]) + | "@serialize" -> fun v k -> k (Serialized v) + | "@deserialize" -> fun v k -> k (as_serialized v) | "Array.init" -> fun v k -> (match Value.as_tup v with | [len; x] -> diff --git a/src/rename.ml b/src/rename.ml index 20741e6fa0b..a23a7f6eb84 100644 --- a/src/rename.ml +++ b/src/rename.ml @@ -6,12 +6,13 @@ module Renaming = Map.Make(String) (* One traversal for each syntactic category, named by that category *) -let stamp = ref 0 +module Stamps = Map.Make(String) +let stamps = ref Stamps.empty let fresh_id id = - let i' = Printf.sprintf "%s@%i" id.it (!stamp) in - stamp := !stamp+1; - i' + let n = Lib.Option.get (Stamps.find_opt id.it !stamps) 0 in + stamps := Stamps.add id.it (n + 1) !stamps; + Printf.sprintf "%s/%i" id.it n let id rho i = try {i with it = Renaming.find i.it rho} @@ -21,6 +22,10 @@ let id_bind rho i = let i' = fresh_id i in ({i with it = i'}, Renaming.add i.it i' rho) +let arg_bind rho i = + let i' = fresh_id i in + ({i with it = i'}, Renaming.add i.it i' rho) + let rec exp rho e = {e with it = exp' rho e.it} @@ -47,11 +52,7 @@ and exp' rho e = match e with in BlockE (ds', exp rho' e1) | IfE (e1, e2, e3) -> IfE (exp rho e1, exp rho e2, exp rho e3) | SwitchE (e, cs) -> SwitchE (exp rho e, cases rho cs) - | WhileE (e1, e2) -> WhileE (exp rho e1, exp rho e2) - | LoopE (e1, None) -> LoopE (exp rho e1, None) - | LoopE (e1, Some e2) -> LoopE (exp rho e1, Some (exp rho e2)) - | ForE (p, e1, e2) -> let p',rho' = pat rho p in - ForE (p', exp rho e1, exp rho' e2) + | LoopE e1 -> LoopE (exp rho e1) | LabelE (i, t, e) -> let i',rho' = id_bind rho i in LabelE(i', t, exp rho' e) | BreakE (i, e) -> BreakE(id rho i,exp rho e) @@ -64,7 +65,7 @@ and exp' rho e = match e with DeclareE (i', t, exp rho' e) | DefineE (i, m, e) -> DefineE (id rho i, m, exp rho e) | FuncE (x, s, tp, p, t, e) -> - let p', rho' = pat rho p in + let p', rho' = args rho p in let e' = exp rho' e in FuncE (x, s, tp, p', t, e') | NewObjE (s, fs, t) -> NewObjE (s, fields rho fs, t) @@ -74,6 +75,14 @@ and exps rho es = List.map (exp rho) es and fields rho fs = List.map (fun f -> { f with it = { f.it with var = id rho f.it.var } }) fs +and args rho as_ = + match as_ with + | [] -> ([],rho) + | a::as_ -> + let (a', rho') = arg_bind rho a in + let (as_', rho'') = args rho' as_ in + (a'::as_', rho'') + and pat rho p = let p',rho = pat' rho p.it in {p with it = p'}, rho diff --git a/src/serialization.ml b/src/serialization.ml new file mode 100644 index 00000000000..e2f0ae02df6 --- /dev/null +++ b/src/serialization.ml @@ -0,0 +1,268 @@ +open Source +open Ir +module T = Type +open Construct + +(* +This transforms + * the types of shared functions to pass ElemBufs (according to their arity) + * shared function definitions to call deserialize on the arguments + * calls to shared functions to call serialize on the arguments +*) + +module Transform() = struct + + module ConRenaming = Env.Make(struct type t = T.con let compare = Con.compare end) + + (* the state *) + + (* maps constructors to new constructors (new name, new stamp, new kind) + it is initialized with the type constructors defined outside here, which are + not rewritten. + + If we run this translation on two program fragments (e.g. prelude and program) + we would have to pass down the `con_renaming`. But this is simply the right thing + to do for a pass that changes the context. + *) + + let con_renaming = ref ConRenaming.empty + + (* The primitive serialization functions *) + let deserialize_prim = + let open Type in + let var : var = "A" in + primE "@deserialize" + (Func (Local, Returns, [{var; bound = Shared}], [Serialized (Var (var, 0))], [(Var (var, 0))])) + let serialize_prim = + let open Type in + let var : var = "A" in + primE "@serialize" + (Func (Local, Returns, [{var; bound = Shared}], [Var (var, 0)], [Serialized (Var (var, 0))])) + + let deserialize e = + let t = T.as_serialized e.note.note_typ in + callE deserialize_prim [t] e + + let serialize e = + let t = e.note.note_typ in + callE serialize_prim [t] e + + let serialized_arg a = + { it = a.it ^ "/raw"; note = T.Serialized a.note; at = a.at } + + let rec map_tuple n f e = match n, e.it with + | 0, _ -> e + | _, TupE es -> + assert (List.length es = n); + tupE (List.map f es) + | _, BlockE (ds, e) -> + blockE ds (map_tuple n f e) + | _, _ -> + let ts = T.as_tup e.note.note_typ in + assert (List.length ts = n); + let vs = fresh_vars "tup" ts in + blockE [letP (seqP (List.map varP vs)) e] + (tupE (List.map f vs)) + + let rec t_typ (t:T.typ) = + match t with + | T.Prim _ + | T.Shared + | T.Any + | T.Non + | T.Pre + | T.Var _ -> t + + | T.Con (c, ts) -> + T.Con (t_con c, List.map t_typ ts) + | T.Array t -> T.Array (t_typ t) + | T.Tup ts -> T.Tup (List.map t_typ ts) + | T.Func (T.Sharable, c, tbs, t1, t2) -> + assert (c = T.Returns); + assert (t2 = []); (* A returning sharable function has no return values *) + T.Func (T.Sharable, T.Returns, tbs, List.map (fun t -> T.Serialized (t_typ t)) t1, []) + | T.Func (T.Local, c, tbs, t1, t2) -> + T.Func (T.Local, c, List.map t_bind tbs, List.map t_typ t1, List.map t_typ t2) + | T.Opt t -> T.Opt (t_typ t) + | T.Obj (s, fs) -> T.Obj (s, List.map t_field fs) + | T.Mut t -> T.Mut (t_typ t) + + | T.Serialized t -> assert false (* This transformation should only run once *) + | T.Async t -> assert false (* Should happen after async-translation *) + + and t_bind {T.var; T.bound} = + {T.var; T.bound = t_typ bound} + + and t_binds typbinds = List.map t_bind typbinds + + and t_kind k = + match k with + | T.Abs(typ_binds,typ) -> + T.Abs(t_binds typ_binds, t_typ typ) + | T.Def(typ_binds,typ) -> + T.Def(t_binds typ_binds, t_typ typ) + + and t_con c = + match ConRenaming.find_opt c (!con_renaming) with + | Some c' -> c' + | None -> + let clone = Con.clone c (T.Abs ([], T.Pre)) in + con_renaming := ConRenaming.add c clone (!con_renaming); + (* Need to extend con_renaming before traversing the kind *) + Type.set_kind clone (t_kind (Con.kind c)); + clone + + and t_field {T.lab; T.typ} = + { T.lab; T.typ = t_typ typ } + + let rec t_exp (exp: exp) = + { it = t_exp' exp; + note = { note_typ = t_typ exp.note.note_typ; + note_eff = exp.note.note_eff}; + at = exp.at; + } + and t_exp' (exp:exp) = + let exp' = exp.it in + match exp' with + | CallE (cc, exp1, typs, exp2) -> + begin match cc.Value.sort with + | T.Local -> + CallE(cc, t_exp exp1, List.map t_typ typs, t_exp exp2) + | T.Sharable -> + assert (T.is_unit exp.note.note_typ); + if cc.Value.n_args = 1 + then + let exp2' = serialize (t_exp exp2) in + CallE (cc, t_exp exp1, [], exp2') + else + let exp2' = map_tuple cc.Value.n_args serialize (t_exp exp2) in + CallE (cc, t_exp exp1, [], exp2') + end + | FuncE (x, cc, typbinds, args, typT, exp) -> + begin match cc.Value.sort with + | T.Local -> + FuncE (x, cc, t_typ_binds typbinds, t_args args, t_typ typT, t_exp exp) + | T.Sharable -> + assert (T.is_unit typT); + let args' = t_args args in + let raw_args = List.map serialized_arg args' in + let body' = + blockE [letP (tupP (List.map varP (List.map exp_of_arg args'))) + (tupE (List.map deserialize (List.map exp_of_arg raw_args))) ] + (t_exp exp) in + FuncE (x, cc, [], raw_args, T.unit, body') + end + | PrimE _ + | LitE _ -> exp' + | VarE id -> exp' + | UnE (ot, op, exp1) -> + UnE (t_typ ot, op, t_exp exp1) + | BinE (ot, exp1, op, exp2) -> + BinE (t_typ ot, t_exp exp1, op, t_exp exp2) + | RelE (ot, exp1, op, exp2) -> + RelE (t_typ ot, t_exp exp1, op, t_exp exp2) + | TupE exps -> + TupE (List.map t_exp exps) + | OptE exp1 -> + OptE (t_exp exp1) + | ProjE (exp1, n) -> + ProjE (t_exp exp1, n) + | DotE (exp1, id) -> + DotE (t_exp exp1, id) + | ActorDotE (exp1, id) -> + ActorDotE (t_exp exp1, id) + | AssignE (exp1, exp2) -> + AssignE (t_exp exp1, t_exp exp2) + | ArrayE (mut, t, exps) -> + ArrayE (mut, t_typ t, List.map t_exp exps) + | IdxE (exp1, exp2) -> + IdxE (t_exp exp1, t_exp exp2) + | BlockE b -> + BlockE (t_block b) + | IfE (exp1, exp2, exp3) -> + IfE (t_exp exp1, t_exp exp2, t_exp exp3) + | SwitchE (exp1, cases) -> + let cases' = List.map + (fun {it = {pat;exp}; at; note} -> + {it = {pat = t_pat pat ;exp = t_exp exp}; at; note}) + cases + in + SwitchE (t_exp exp1, cases') + | LoopE exp1 -> + LoopE (t_exp exp1) + | LabelE (id, typ, exp1) -> + LabelE (id, t_typ typ, t_exp exp1) + | BreakE (id, exp1) -> + BreakE (id, t_exp exp1) + | RetE exp1 -> + RetE (t_exp exp1) + | AsyncE _ -> assert false + | AwaitE _ -> assert false + | AssertE exp1 -> + AssertE (t_exp exp1) + | DeclareE (id, typ, exp1) -> + DeclareE (id, t_typ typ, t_exp exp1) + | DefineE (id, mut ,exp1) -> + DefineE (id, mut, t_exp exp1) + | ActorE (id, ds, fs, typ) -> + ActorE (id, t_decs ds, t_fields fs, t_typ typ) + | NewObjE (sort, ids, t) -> + NewObjE (sort, t_fields ids, t_typ t) + + and t_dec dec = { dec with it = t_dec' dec.it } + + and t_dec' dec' = + match dec' with + | TypD con_id -> TypD (t_con con_id) + | LetD (pat,exp) -> LetD (t_pat pat,t_exp exp) + | VarD (id,exp) -> VarD (id,t_exp exp) + + and t_decs decs = List.map t_dec decs + + and t_block (ds, exp) = (t_decs ds, t_exp exp) + + and t_fields fs = + List.map (fun f -> { f with note = t_typ f.note }) fs + + and t_args as_ = + List.map (fun a -> { a with note = t_typ a.note }) as_ + + and t_pat pat = + { pat with + it = t_pat' pat.it; + note = t_typ pat.note } + + and t_pat' pat = + match pat with + | WildP + | LitP _ + | VarP _ -> + pat + | TupP pats -> + TupP (List.map t_pat pats) + | OptP pat1 -> + OptP (t_pat pat1) + | AltP (pat1, pat2) -> + AltP (t_pat pat1, t_pat pat2) + + and t_typ_bind' {con; bound} = + {con = t_con con; bound = t_typ bound} + + and t_typ_bind typ_bind = + { typ_bind with it = t_typ_bind' typ_bind.it } + + and t_typ_binds typbinds = List.map t_typ_bind typbinds + + and t_prog (prog, flavor) = (t_block prog, { flavor with serialized = true }) + +end + +let transform env prog = + let module T = Transform() in + (* + Initialized the con_renaming with those type constructors already in scope. + Eventually, pipeline will allow us to pass the con_renaming to downstream program + fragments, then we would simply start with an empty con_renaming and the prelude. + *) + Type.ConSet.iter (fun c -> T.con_renaming := T.ConRenaming.add c c (!T.con_renaming)) env.Typing.con_env; + T.t_prog prog diff --git a/src/tailcall.ml b/src/tailcall.ml index 6968903f8d7..b042360111a 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -43,7 +43,7 @@ TODO: optimize for multiple arguments using multiple temps (not a tuple). type func_info = { func: S.id; typ_binds: typ_bind list; - temp: var; + temps: var list; label: S.id; tail_called: bool ref; } @@ -77,6 +77,16 @@ let rec tailexp env e = and exp env e : exp = {e with it = exp' {env with tail_pos = false} e} +and assignEs vars exp : dec list = + match vars, exp.it with + | [v], _ -> [ expD (assignE v exp) ] + | _, TupE es when List.length es = List.length vars -> + List.map expD (List.map2 assignE vars es) + | _, _ -> + let tup = fresh_var "tup" (typ exp) in + letD tup exp :: + List.mapi (fun i v -> expD (assignE v (projE v i))) vars + and exp' env e : exp' = match e.it with | VarE _ | LitE _ @@ -95,21 +105,17 @@ and exp' env e : exp' = match e.it with begin match e1.it, env with | VarE f1, { tail_pos = true; - info = Some { func; typ_binds; temp; label; tail_called } } + info = Some { func; typ_binds; temps; label; tail_called } } when f1.it = func.it && are_generic_insts typ_binds insts -> tail_called := true; - (blockE [expD (assignE temp (exp env e2))] + (blockE (assignEs temps (exp env e2)) (breakE label (tupE []))).it | _,_-> CallE(cc, exp env e1, insts, exp env e2) end | BlockE (ds, e) -> BlockE (block env ds e) | IfE (e1, e2, e3) -> IfE (exp env e1, tailexp env e2, tailexp env e3) | SwitchE (e, cs) -> SwitchE (exp env e, cases env cs) - | WhileE (e1, e2) -> WhileE (exp env e1, exp env e2) - | LoopE (e1, None) -> LoopE (exp env e1, None) - | LoopE (e1, Some e2) -> LoopE (exp env e1, Some (exp env e2)) - | ForE (p, e1, e2) -> let env1 = pat env p in - ForE (p, exp env e1, exp env1 e2) + | LoopE e1 -> LoopE (exp env e1) | LabelE (i, t, e) -> let env1 = bind env i None in LabelE(i, t, exp env1 e) | BreakE (i, e) -> BreakE(i,exp env e) @@ -122,15 +128,19 @@ and exp' env e : exp' = match e.it with | DeclareE (i, t, e) -> let env1 = bind env i None in DeclareE (i, t, tailexp env1 e) | DefineE (i, m, e) -> DefineE (i, m, exp env e) - | FuncE (x, cc, tbs, p, typT, exp0) -> - let env1 = pat {tail_pos = true; info = None} p in - let exp0' = tailexp env1 exp0 in - FuncE (x, cc, tbs, p, typT, exp0') - | ActorE (i, ds, fs, t) -> ActorE (i, ds, fs, t) (* TODO: decent into ds *) + | FuncE (x, cc, tbs, as_, typT, exp0) -> + let env1 = { tail_pos = true; info = None} in + let env2 = args env1 as_ in + let exp0' = tailexp env2 exp0 in + FuncE (x, cc, tbs, as_, typT, exp0') + | ActorE (i, ds, fs, t) -> ActorE (i, ds, fs, t) (* TODO: descent into ds *) | NewObjE (s,is,t) -> NewObjE (s, is, t) and exps env es = List.map (exp env) es +and args env as_ = + List.fold_left (fun env a -> bind env a None) env as_ + and pat env p = let env = pat' env p.it in env @@ -171,39 +181,43 @@ and dec env d = and dec' env d = match d.it with (* A local let bound function, this is what we are looking for *) + (* TODO: Do we need to detect more? A tuple of functions? *) | LetD (({it = VarP id;_} as id_pat), - ({it = FuncE (x, ({ Value.sort = Local; _} as cc), tbs, p, typT, exp0);_} as funexp)) -> + ({it = FuncE (x, ({ Value.sort = Local; _} as cc), tbs, as_, typT, exp0);_} as funexp)) -> let env = bind env id None in begin fun env1 -> - let temp = fresh_var (Mut p.note) in - let l = fresh_id () in + let temps = fresh_vars "temp" (List.map (fun a -> Mut a.note) as_) in + let label = fresh_id "tailcall" () in let tail_called = ref false in let env2 = { tail_pos = true; info = Some { func = id; typ_binds = tbs; - temp = temp; - label = l; - tail_called = tail_called } } + temps; + label; + tail_called } } in - let env3 = pat env2 p in (* shadow id if necessary *) + let env3 = args env2 as_ in (* shadow id if necessary *) let exp0' = tailexp env3 exp0 in let cs = List.map (fun (tb : typ_bind) -> Con (tb.it.con, [])) tbs in if !tail_called then let ids = match typ funexp with - | Func( _, _, _, dom, _) -> List.map (fun t -> fresh_var (open_ cs t)) dom + | Func( _, _, _, dom, _) -> + fresh_vars "id" (List.map (fun t -> open_ cs t) dom) | _ -> assert false in - let args = seqP (List.map varP ids) in let l_typ = Type.unit in let body = - blockE [varD (id_of_exp temp) (seqE ids)] - (loopE - (labelE l l_typ - (blockE [letP p (immuteE temp)] (retE exp0'))) None) + blockE (List.map2 (fun t i -> varD (id_of_exp t) i) temps ids) ( + loopE ( + labelE label l_typ (blockE + (List.map2 (fun a t -> letD (exp_of_arg a) (immuteE t)) as_ temps) + (retE exp0')) + ) + ) in - LetD (id_pat, {funexp with it = FuncE (x, cc, tbs, args, typT, body)}) + LetD (id_pat, {funexp with it = FuncE (x, cc, tbs, List.map arg_of_exp ids, typT, body)}) else - LetD (id_pat, {funexp with it = FuncE (x, cc, tbs, p, typT, exp0')}) + LetD (id_pat, {funexp with it = FuncE (x, cc, tbs, as_, typT, exp0')}) end, env | LetD (p, e) -> diff --git a/src/type.ml b/src/type.ml index 18db3887d21..2939eb7f195 100644 --- a/src/type.ml +++ b/src/type.ml @@ -34,6 +34,7 @@ and typ = | Async of typ (* future *) | Mut of typ (* mutable type *) | Shared (* sharable *) + | Serialized of typ (* a serialized value *) | Any (* top *) | Non (* bottom *) | Pre (* pre-type *) @@ -100,6 +101,12 @@ let array_obj t = | Mut t' -> Obj (Object Local, List.sort compare_field (mut t')) | t -> Obj (Object Local, List.sort compare_field (immut t)) +let text_obj = + let immut = + [ {lab = "chars"; typ = Func (Local, Returns, [], [], [iter_obj (Prim Char)])}; + {lab = "len"; typ = Func (Local, Returns, [], [], [Prim Nat])}; + ] in + Obj (Object Local, List.sort compare_field immut) (* Shifting *) @@ -118,6 +125,7 @@ let rec shift i n t = | Obj (s, fs) -> Obj (s, List.map (shift_field n i) fs) | Mut t -> Mut (shift i n t) | Shared -> Shared + | Serialized t -> Serialized (shift i n t) | Any -> Any | Non -> Non | Pre -> Pre @@ -152,6 +160,7 @@ let rec subst sigma t = | Obj (s, fs) -> Obj (s, List.map (subst_field sigma) fs) | Mut t -> Mut (subst sigma t) | Shared -> Shared + | Serialized t -> Serialized (subst sigma t) | Any -> Any | Non -> Non | Pre -> Pre @@ -191,6 +200,7 @@ let rec open' i ts t = | Obj (s, fs) -> Obj (s, List.map (open_field i ts) fs) | Mut t -> Mut (open' i ts t) | Shared -> Shared + | Serialized t -> Serialized (open' i ts t) | Any -> Any | Non -> Non | Pre -> Pre @@ -248,6 +258,7 @@ let is_pair = function Tup [_; _] -> true | _ -> false let is_func = function Func _ -> true | _ -> false let is_async = function Async _ -> true | _ -> false let is_mut = function Mut _ -> true | _ -> false +let is_serialized = function Serialized _ -> true | _ -> false let invalid s = raise (Invalid_argument ("Type." ^ s)) @@ -262,6 +273,7 @@ let as_func = function Func (s, c, tbs, ts1, ts2) -> s, c, tbs, ts1, ts2 | _ -> let as_async = function Async t -> t | _ -> invalid "as_async" let as_mut = function Mut t -> t | _ -> invalid "as_mut" let as_immut = function Mut t -> t | t -> t +let as_serialized = function Serialized t -> t | _ -> invalid "as_serialized" let as_seq = function Tup ts -> ts | t -> [t] @@ -272,6 +284,7 @@ let as_prim_sub p t = match promote t with let rec as_obj_sub lab t = match promote t with | Obj (s, tfs) -> s, tfs | Array t -> as_obj_sub lab (array_obj t) + | Prim Text -> as_obj_sub lab text_obj | Non -> Object Sharable, [{lab; typ = Non}] | _ -> invalid "as_obj_sub" let as_array_sub t = match promote t with @@ -293,9 +306,9 @@ let as_pair_sub t = match promote t with | Tup [t1; t2] -> t1, t2 | Non -> Non, Non | _ -> invalid "as_pair_sub" -let as_func_sub n t = match promote t with - | Func (_, _, tbs, ts1, ts2) -> tbs, seq ts1, seq ts2 - | Non -> Lib.List.make n {var = "X"; bound = Any}, Any, Non +let as_func_sub default_s default_arity t = match promote t with + | Func (s, _, tbs, ts1, ts2) -> s, tbs, seq ts1, seq ts2 + | Non -> default_s, Lib.List.make default_arity {var = "X"; bound = Any}, Any, Non | _ -> invalid "as_func_sub" let as_mono_func_sub t = match promote t with | Func (_, _, [], ts1, ts2) -> seq ts1, seq ts2 @@ -328,6 +341,7 @@ let rec span = function | Array _ | Func _ | Shared | Any -> None | Opt _ -> Some 2 | Mut t -> span t + | Serialized t -> None | Non -> Some 0 @@ -361,6 +375,7 @@ let rec avoid' cons = function | Async t -> Async (avoid' cons t) | Obj (s, fs) -> Obj (s, List.map (avoid_field cons) fs) | Mut t -> Mut (avoid' cons t) + | Serialized t -> Serialized (avoid' cons t) and avoid_bind cons {var; bound} = {var; bound = avoid' cons bound} @@ -372,6 +387,44 @@ let avoid cons t = if cons = ConSet.empty then t else avoid' cons t +(* Checking for concrete types *) + +module TS = Set.Make (struct type t = typ let compare = compare end) + +(* +This check is a stop-gap measure until we have an IDL strategy that +allows polymorphic types, see #250. It is not what we desire for ActorScript. +*) + +let is_concrete t = + let seen = ref TS.empty in (* break the cycles *) + let rec go t = + TS.mem t !seen || + begin + seen := TS.add t !seen; + match t with + | Var _ -> assert false + | (Prim _ | Any | Non | Shared | Pre) -> true + | Con (c, ts) -> + begin match Con.kind c with + | Abs _ -> false + | Def (tbs,t) -> go (open_ ts t) (* TBR this may fail to terminate *) + end + | Array t -> go t + | Tup ts -> List.for_all go ts + | Func (s, c, tbs, ts1, ts2) -> + let ts = open_binds tbs in + List.for_all go (List.map (open_ ts) ts1) && + List.for_all go (List.map (open_ ts) ts2) + | Opt t -> go t + | Async t -> go t + | Obj (s, fs) -> List.for_all (fun f -> go f.typ) fs + | Mut t -> go t + | Serialized t -> go t + end + in go t + + (* Equivalence & Subtyping *) @@ -464,6 +517,8 @@ let rec rel_typ rel eq t1 t2 = rel_typ rel eq t1' t2' | Mut t1', Mut t2' -> eq_typ rel eq t1' t2' + | Serialized t1', Serialized t2' -> + eq_typ rel eq t1' t2' (* TBR: eq or sub? Does it matter? *) | _, _ -> false end @@ -646,6 +701,8 @@ and string_of_typ' vs t = sprintf "actor %s" (string_of_typ_nullary vs (Obj (Object Local, fs))) | Mut t -> sprintf "var %s" (string_of_typ' vs t) + | Serialized t -> + sprintf "serialized %s" (string_of_typ' vs t) | t -> string_of_typ_nullary vs t and string_of_field vs {lab; typ} = diff --git a/src/type.mli b/src/type.mli index 9fb29dd4d07..37cc11163a0 100644 --- a/src/type.mli +++ b/src/type.mli @@ -34,6 +34,7 @@ and typ = | Async of typ (* future *) | Mut of typ (* mutable type *) | Shared (* sharable *) + | Serialized of typ (* a serialized value *) | Any (* top *) | Non (* bottom *) | Pre (* pre-type *) @@ -69,6 +70,7 @@ val is_pair : typ -> bool val is_func : typ -> bool val is_async : typ -> bool val is_mut : typ -> bool +val is_serialized : typ -> bool val as_prim : prim -> typ -> unit val as_obj : typ -> obj_sort * field list @@ -81,6 +83,7 @@ val as_func : typ -> sharing * control * bind list * typ list * typ list val as_async : typ -> typ val as_mut : typ -> typ val as_immut : typ -> typ +val as_serialized : typ -> typ val as_prim_sub : prim -> typ -> unit val as_obj_sub : string -> typ -> obj_sort * field list @@ -89,7 +92,7 @@ val as_opt_sub : typ -> typ val as_tup_sub : int -> typ -> typ list val as_unit_sub : typ -> unit val as_pair_sub : typ -> typ * typ -val as_func_sub : int -> typ -> bind list * typ * typ +val as_func_sub : sharing -> int -> typ -> sharing * bind list * typ * typ val as_mono_func_sub : typ -> typ * typ val as_async_sub : typ -> typ @@ -117,6 +120,7 @@ val promote : typ -> typ exception Unavoidable of con val avoid : ConSet.t -> typ -> typ (* raise Unavoidable *) +val is_concrete : typ -> bool (* Equivalence and Subtyping *) diff --git a/src/typing.ml b/src/typing.ml index 115a3f63d3a..e0aeeda523f 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -171,9 +171,9 @@ and check_typ' env typ : T.typ = | [] -> () | [T.Async t2] -> if not (T.sub t2 T.Shared) then - error env typ1.at "shared function has non-shared result type\n %s" + error env typ2.at "shared function has non-shared result type\n %s" (T.string_of_typ_expand t2); - | _ -> error env typ1.at "shared function has non-async result type\n %s" + | _ -> error env typ2.at "shared function has non-async result type\n %s" (T.string_of_typ_expand (T.seq ts2)) ) end; @@ -470,12 +470,18 @@ and infer_exp'' env exp : T.typ = if not (T.sub t1 T.Shared) then error env pat.at "shared function has non-shared parameter type\n %s" (T.string_of_typ_expand t1); + if not (T.is_concrete t1) then + error env pat.at "shared function parameter contains abstract type\n %s" + (T.string_of_typ_expand t1); begin match t2 with | T.Tup [] -> () | T.Async t2 -> if not (T.sub t2 T.Shared) then error env typ.at "shared function has non-shared result type\n %s" (T.string_of_typ_expand t2); + if not (T.is_concrete t2) then + error env typ.at "shared function result contains abstract type\n %s" + (T.string_of_typ_expand t2); if not (isAsyncE exp) then error env exp.at "shared function with async type has non-async body" | _ -> error env typ.at "shared function has non-async result type\n %s" @@ -494,15 +500,27 @@ and infer_exp'' env exp : T.typ = T.Func (sort.it, c, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2) | CallE (exp1, insts, exp2) -> let t1 = infer_exp_promote env exp1 in - (try - let tbs, t2, t = T.as_func_sub (List.length insts) t1 in - let ts = check_inst_bounds env tbs insts exp.at in - if not env.pre then check_exp env (T.open_ ts t2) exp2; - T.open_ ts t - with Invalid_argument _ -> - error env exp1.at "expected function type, but expression produces type\n %s" - (T.string_of_typ_expand t1) - ) + let sort, tbs, t_arg, t_ret = + try T.as_func_sub T.Local (List.length insts) t1 + with Invalid_argument _ -> + error env exp1.at "expected function type, but expression produces type\n %s" + (T.string_of_typ_expand t1) + in + let ts = check_inst_bounds env tbs insts exp.at in + let t_arg = T.open_ ts t_arg in + let t_ret = T.open_ ts t_ret in + if not env.pre then begin + check_exp env t_arg exp2; + if sort = T.Sharable then begin + if not (T.is_concrete t_arg) then + error env exp1.at "shared function argument contains abstract type\n %s" + (T.string_of_typ_expand t_arg); + if not (T.is_concrete t_ret) then + error env exp2.at "shared function call result contains abstract type\n %s" + (T.string_of_typ_expand t_ret); + end + end; + t_ret | BlockE decs -> let t, scope = infer_block env decs exp.at in (try T.avoid scope.con_env t with T.Unavoidable c -> @@ -773,7 +791,7 @@ and infer_pat' env pat : T.typ * val_env = let t = check_typ env typ in t, check_pat env t pat1 | ParP pat1 -> - infer_pat env pat1 + infer_pat env pat1 and infer_pats at env pats ts ve : T.typ list * val_env = match pats with @@ -841,7 +859,7 @@ and check_pat' env t pat : val_env = error env pat.at "variables are not allowed in pattern alternatives"; T.Env.empty | ParP pat1 -> - check_pat env t pat1 + check_pat env t pat1 | _ -> let t', ve = infer_pat env pat in if not (T.sub t t') then @@ -892,8 +910,8 @@ and pub_pat pat xs : region T.Env.t * region T.Env.t = | AltP (pat1, _) | OptP pat1 | AnnotP (pat1, _) - | ParP pat1 - -> pub_pat pat1 xs + | ParP pat1 -> + pub_pat pat1 xs and pub_typ_id id (xs, ys) : region T.Env.t * region T.Env.t = (T.Env.add id.it id.at xs, ys) @@ -1162,12 +1180,26 @@ and infer_dec_valdecs env dec : val_env = let check_prog scope prog : scope Diag.result = Diag.with_message_store (fun msgs -> - Definedness.check_prog msgs prog; - let env = env_of_scope msgs scope in - recover_opt (check_block env T.unit prog.it) prog.at) + recover_opt + (fun prog -> + let env = env_of_scope msgs scope in + let res = check_block env T.unit prog.it prog.at in + Definedness.check_prog msgs prog; + res) + prog + ) let infer_prog scope prog : (T.typ * scope) Diag.result = - Diag.with_message_store (fun msgs -> - Definedness.check_prog msgs prog; - let env = env_of_scope msgs scope in - recover_opt (infer_block env prog.it) prog.at) + Diag.with_message_store + (fun msgs -> + recover_opt + (fun prog -> + let env = env_of_scope msgs scope in + let res = infer_block env prog.it prog.at in + Definedness.check_prog msgs prog; + res + ) + prog + ) + + diff --git a/src/value.ml b/src/value.ml index 9a4613045ca..7a7986f6e26 100644 --- a/src/value.ml +++ b/src/value.ml @@ -61,8 +61,8 @@ struct let lognot i = inj (Rep.lognot (proj i)) let logxor i j = inj (Rep.logxor (proj i) (proj j)) let shift_left i j = Rep.shift_left i j - let shift_right = Rep.shift_right - let shift_right_logical = Rep.shift_right_logical + let shift_right i j = let res = Rep.shift_right i j in inj (proj res) + let shift_right_logical i j = let res = Rep.shift_right_logical i j in inj (proj res) let of_int i = inj (Rep.of_int i) let to_int i = Rep.to_int (proj i) let to_string i = group_num (Rep.to_string (proj i)) @@ -222,6 +222,7 @@ and value = | Func of call_conv * func | Async of async | Mut of value ref + | Serialized of value and async = {result : def; mutable waiters : value cont list} and def = value Lib.Promise.t @@ -258,6 +259,7 @@ let as_opt = function Opt v -> v | _ -> invalid "as_opt" let as_tup = function Tup vs -> vs | _ -> invalid "as_tup" let as_unit = function Tup [] -> () | _ -> invalid "as_unit" let as_pair = function Tup [v1; v2] -> v1, v2 | _ -> invalid "as_pair" +let as_serialized = function Serialized v -> v | _ -> invalid "as_serialized" let obj_of_array a = let get = local_func 1 1 @@ fun v k -> @@ -296,7 +298,21 @@ let obj_of_array a = Env.from_list ["get", get; "set", set; "len", len; "keys", keys; "vals", vals] -let as_obj = function Obj ve -> ve | Array a -> obj_of_array a | _ -> invalid "as_obj" +let obj_of_text t = + let chars = local_func 0 1 @@ fun v k -> + as_unit v; + let i = ref 0 in + let s = Wasm.Utf8.decode t in + let next = local_func 0 1 @@ fun v k' -> + if !i = List.length s then k' Null else + let v = Opt (Char (List.nth s !i)) in incr i; k' v + in k (Obj (Env.singleton "next" next)) in + let len = local_func 0 1 @@ fun v k -> + as_unit v; k (Int (Nat.of_int (List.length (Wasm.Utf8.decode t)))) in + + Env.from_list ["chars", chars; "len", len] + +let as_obj = function Obj ve -> ve | Array a -> obj_of_array a | Text t -> obj_of_text t | _ -> invalid "as_obj" let as_func = function Func (cc, f) -> cc, f | _ -> invalid "as_func" let as_async = function Async a -> a | _ -> invalid "as_async" let as_mut = function Mut r -> r | _ -> invalid "as_mut" diff --git a/src/value.mli b/src/value.mli index c0362d0f063..7d51d1042ab 100644 --- a/src/value.mli +++ b/src/value.mli @@ -87,6 +87,7 @@ and value = | Func of call_conv * func | Async of async | Mut of value ref + | Serialized of value and async = {result : def; mutable waiters : value cont list} and def = value Lib.Promise.t @@ -129,6 +130,7 @@ val as_obj : value -> value Env.t val as_func : value -> call_conv * func val as_async : value -> async val as_mut : value -> value ref +val as_serialized : value -> value (* Ordering *) diff --git a/stdlib/assocList.as b/stdlib/assocList.as index 1bb2a354bbe..f75fc1b397a 100644 --- a/stdlib/assocList.as +++ b/stdlib/assocList.as @@ -78,7 +78,7 @@ let AssocList = new { /** `diff` --------- - The key-value pairs of the final list consists of those pairs of + The key-value pairs of the final list consist of those pairs of the left list whose keys are not present in the right list; the values of the right list are irrelevant. */ diff --git a/stdlib/examples/produce-exchange/serverActor.as b/stdlib/examples/produce-exchange/serverActor.as index cbc335372ac..8e03022fb3e 100644 --- a/stdlib/examples/produce-exchange/serverActor.as +++ b/stdlib/examples/produce-exchange/serverActor.as @@ -4,7 +4,7 @@ -------------------- */ -actor class Server() { +actor { /** PESS: Server Actor diff --git a/stdlib/list.as b/stdlib/list.as index 87dcb4c47f7..d9fe19613b8 100644 --- a/stdlib/list.as +++ b/stdlib/list.as @@ -276,13 +276,7 @@ let List = new { switch (l1, l2) { case (null, _) { true }; case (_, null) { false }; - case (?(h1,t1), ?(h2,t2)) { - if (lte(h1,h2)) { - rec(t1, t2) - } else { - false - } - }; + case (?(h1,t1), ?(h2,t2)) { lte(h1,h2) and rec(t1, t2) }; } }; rec(l1, l2) @@ -296,13 +290,7 @@ let List = new { case (null, null) { true }; case (null, _) { false }; case (_, null) { false }; - case (?(h1,t1), ?(h2,t2)) { - if (eq(h1,h2)) { - rec(t1, t2) - } else { - false - } - }; + case (?(h1,t1), ?(h2,t2)) { eq(h1,h2) and rec(t1, t2) }; } }; rec(l1, l2) diff --git a/stdlib/setDb.as b/stdlib/setDb.as index 4d41cccb86d..e18cfdebece 100644 --- a/stdlib/setDb.as +++ b/stdlib/setDb.as @@ -106,7 +106,6 @@ let SetDb = new { // also: test that merge agrees with disj: let r1 = Set.union(s1, s2, natEq); let r2 = Trie.disj(s1, s2, natEq, func (_:?(),_:?()):(())=()); - //xxx assert(Trie.equalStructure(r1, r2, natEq, Set.unitEq)); print ";\n"; setDbPrint(r1); diff --git a/stdlib/trie.as b/stdlib/trie.as index 2a58da6d8ee..84400046279 100644 --- a/stdlib/trie.as +++ b/stdlib/trie.as @@ -403,12 +403,12 @@ let Trie = new { makeBin(t0, t1) }; case (false, true) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption tr }; case (true, false) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption tr }; @@ -534,12 +534,12 @@ let Trie = new { makeBin(t0, t1) }; case (false, true) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption tl }; case (true, false) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption tl }; @@ -608,12 +608,12 @@ let Trie = new { makeBin(t0, t1) }; case (false, true) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption makeEmpty() }; case (true, false) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption makeEmpty() }; @@ -657,12 +657,12 @@ let Trie = new { makeBin(t0, t1) }; case (false, true) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption makeEmpty() }; case (true, false) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption makeEmpty() }; diff --git a/test/Makefile b/test/Makefile index 19b6c2eec37..e8763d23934 100644 --- a/test/Makefile +++ b/test/Makefile @@ -3,10 +3,14 @@ all: $(MAKE) -C run $(MAKE) -C run-dfinity +MAKE_PAR := $(MAKE) --no-print-directory --load-average -j $(shell getconf _NPROCESSORS_ONLN) --keep-going + quick: - $(MAKE) --no-print-directory --load-average -j -C fail quick - $(MAKE) --no-print-directory --load-average -j -C run quick - $(MAKE) --no-print-directory --load-average -j -C run-dfinity _out/chatpp.done + $(MAKE_PAR) -C fail quick + $(MAKE_PAR) -C run quick + +parallel: quick + $(MAKE_PAR) -C run-dfinity quick coverage: rm -rf _coverage diff --git a/test/dvm.sh b/test/dvm.sh index 5ced2e91b6f..7a1c8f6d372 100755 --- a/test/dvm.sh +++ b/test/dvm.sh @@ -2,11 +2,13 @@ if [ -z "$1" ] then - echo "Usage: $0 foo.wasm" + echo "Usage: $0 .wasm [call-script]" exit 1 fi name="$(basename $1 .wasm)_0" +DVM_TMP=$(mktemp --directory --tmpdir dvm-XXXXXX) +trap 'rm -rf $DVM_TMP' EXIT export LANG=C function dvm_ () { @@ -20,6 +22,16 @@ function dvm_ () { } -dvm_ -q reset -dvm_ -q new $1 -dvm_ -q run $name start +dvm_ -q --db $DVM_TMP reset +dvm_ -q --db $DVM_TMP new $1 +dvm_ -q --db $DVM_TMP run $name start + +if [ -n "$2" ] +then + grep '^//CALL ' $2 | cut -c7- | + while read call + do + echo "DVM: Calling method $call" + dvm_ -q --db $DVM_TMP run $name $call + done +fi diff --git a/test/fail/AST-60.as b/test/fail/AST-60.as new file mode 100644 index 00000000000..7b96dceba4e --- /dev/null +++ b/test/fail/AST-60.as @@ -0,0 +1,2 @@ +let test = (); +let test = (); diff --git a/test/fail/abstract-msgs.as b/test/fail/abstract-msgs.as new file mode 100644 index 00000000000..10d5e595e45 --- /dev/null +++ b/test/fail/abstract-msgs.as @@ -0,0 +1,35 @@ +// In function definitions, parameters with abstract types are not fine +{ shared func foo( x : A ) : () = (); }; +{ shared func foo() : ?A = null; }; +{ func foo() : () = { + { shared func bar( x : A ) : () = (); }; + { shared func bar() : async ?A { null } }; +}}; + +// In function calls, parameters with abstract types are not fine +{ func foo( f : shared A -> (), x : A ) = (f x); }; +{ func foo( f : shared () -> async A ) : async A = async { await (f ())}; }; + +// Just in types, away from definitinos and calls, parameters with abstract types are fine +{ let x : ?(shared A -> ()) = null; }; +{ let x : ?(shared () -> async A) = null; }; +{ let x : ?((shared A -> ()) -> ()) = null; }; +{ let x : ?((shared () -> async A) -> ()) = null; }; + + +// This is mostly because type aliases can have message arguments with type +// variables, as long as they are instantiated with concrete types. So this +// whould be fine: +{ type X = shared B -> (); + shared func foo ( f: X ) = (); +}; + +// But this not +{ type X = shared B -> (); + func foo() { shared func foo(f: X) = (); () } +}; + +// Also, phantom parameters are fine +{ type X = shared () -> (); + func foo() { shared func foo(f: X) = (); () } +}; diff --git a/test/fail/asyncret2.as b/test/fail/asyncret2.as index 7bc988fbe3e..60aa284698e 100644 --- a/test/fail/asyncret2.as +++ b/test/fail/asyncret2.as @@ -1 +1 @@ -func call3(f : shared () -> async B) : async B { f(); }; +func call3(f : shared () -> async Int) : async Int { f(); }; diff --git a/test/fail/asyncret3.as b/test/fail/asyncret3.as index 01b5a29b418..5883d109b8d 100644 --- a/test/fail/asyncret3.as +++ b/test/fail/asyncret3.as @@ -1 +1 @@ -shared func call4(f : shared () -> async B) : async B = f(); +shared func call4(f : shared () -> async Int) : async Int = f(); diff --git a/test/fail/ok/AST-60.tc.ok b/test/fail/ok/AST-60.tc.ok new file mode 100644 index 00000000000..e74c5ac71fc --- /dev/null +++ b/test/fail/ok/AST-60.tc.ok @@ -0,0 +1 @@ +AST-60.as:2.5-2.9: type error, duplicate definition for test in block diff --git a/test/fail/ok/abstract-msgs.tc.ok b/test/fail/ok/abstract-msgs.tc.ok new file mode 100644 index 00000000000..f1619b120dd --- /dev/null +++ b/test/fail/ok/abstract-msgs.tc.ok @@ -0,0 +1,14 @@ +abstract-msgs.as:2.31-2.40: type error, shared function parameter contains abstract type + A/1 +abstract-msgs.as:3.36-3.38: type error, shared function has non-async result type + ?A/3 +abstract-msgs.as:5.20-5.29: type error, shared function parameter contains abstract type + A/5 +abstract-msgs.as:6.25-6.33: type error, shared function result contains abstract type + ?A/5 +abstract-msgs.as:10.58-10.59: type error, shared function argument contains abstract type + A/7 +abstract-msgs.as:11.82-11.84: type error, shared function call result contains abstract type + async A/9 +abstract-msgs.as:29.44-29.53: type error, shared function parameter contains abstract type + X/1 = shared A/19 -> () diff --git a/test/fail/ok/asyncret1.tc.ok b/test/fail/ok/asyncret1.tc.ok index d19068c4431..8dfc6b7f512 100644 --- a/test/fail/ok/asyncret1.tc.ok +++ b/test/fail/ok/asyncret1.tc.ok @@ -1,2 +1,2 @@ -asyncret1.as:1.36-1.38: type error, shared function has non-async result type +asyncret1.as:1.42-1.43: type error, shared function has non-async result type C diff --git a/test/fail/ok/asyncret2.tc.ok b/test/fail/ok/asyncret2.tc.ok index c323bd2a7ec..c9e51a16899 100644 --- a/test/fail/ok/asyncret2.tc.ok +++ b/test/fail/ok/asyncret2.tc.ok @@ -1,4 +1,4 @@ -asyncret2.as:1.63-1.66: type error, expression of type - async B/1 +asyncret2.as:1.54-1.57: type error, expression of type + async Int cannot produce expected type - B/1 + Int diff --git a/test/fail/ok/asyncret3.tc.ok b/test/fail/ok/asyncret3.tc.ok index 5cdd96a69bf..9bd82d6175d 100644 --- a/test/fail/ok/asyncret3.tc.ok +++ b/test/fail/ok/asyncret3.tc.ok @@ -1 +1 @@ -asyncret3.as:1.70-1.73: type error, shared function with async type has non-async body +asyncret3.as:1.61-1.64: type error, shared function with async type has non-async body diff --git a/test/fail/ok/decl-clash.tc.ok b/test/fail/ok/decl-clash.tc.ok index 7b59d9004e4..a8d57a3427b 100644 --- a/test/fail/ok/decl-clash.tc.ok +++ b/test/fail/ok/decl-clash.tc.ok @@ -1,25 +1 @@ -prelude:66.1-91.2: internal error, Env.Make(X).Clash("test") - -Last environment: -@new_async = func -Array_init = func -Array_tabulate = func -abs = func -ignore = func -intToWord16 = func -intToWord32 = func -intToWord8 = func -natToWord16 = func -natToWord32 = func -natToWord8 = func -print = func -printInt = func -range = func -revrange = func -word16ToInt = func -word16ToNat = func -word32ToInt = func -word32ToNat = func -word8ToInt = func -word8ToNat = func - +decl-clash.as:2.5-2.9: type error, duplicate definition for test in block diff --git a/test/fail/ok/one-tuple-ambiguity.tc.ok b/test/fail/ok/one-tuple-ambiguity.tc.ok index d81f6ed4b3b..5baf5c2e6d0 100644 --- a/test/fail/ok/one-tuple-ambiguity.tc.ok +++ b/test/fail/ok/one-tuple-ambiguity.tc.ok @@ -1,14 +1,6 @@ -one-tuple-ambiguity.as:10.2-10.7: type error, expression of type - ((),) -cannot produce expected type - () one-tuple-ambiguity.as:16.3-16.5: type error, literal of type Nat does not have expected type (Nat, Bool) one-tuple-ambiguity.as:16.1-16.5: type error, expected function type, but expression produces type () -one-tuple-ambiguity.as:21.2-21.16: type error, expression of type - ((Nat, Bool),) -cannot produce expected type - (Nat, Bool) diff --git a/test/fail/ok/use-before-define5.wasm.stderr.ok b/test/fail/ok/use-before-define5.wasm.stderr.ok index 52137859dfb..3bdcd030757 100644 --- a/test/fail/ok/use-before-define5.wasm.stderr.ok +++ b/test/fail/ok/use-before-define5.wasm.stderr.ok @@ -5,7 +5,6 @@ non-closed actor: (ActorE (FuncE foo (shared 0 -> 0) - (TupP) () (AssertE (RelE Nat (VarE x) EqOp (LitE (NatLit 1)))) ) diff --git a/test/quick.mk b/test/quick.mk index 274061b9433..130b8a1ed84 100644 --- a/test/quick.mk +++ b/test/quick.mk @@ -2,9 +2,13 @@ TO-TEST = $(patsubst %.as,_out/%.done,$(wildcard *.as)) +.PHONY: quick + quick: $(TO-TEST) +_out: + @ mkdir -p $@ + # run single test, e.g. make _out/AST-56.done -_out/%.done: %.as $(ASC) ../run.sh - @ mkdir -p _out +_out/%.done: %.as $(wildcard ../../src/asc) ../run.sh | _out @ (../run.sh $(RUNFLAGS) $< > $@.tmp && mv $@.tmp $@) || (cat $@.tmp; rm -f $@.tmp; false) diff --git a/test/run-dfinity/data-params.as b/test/run-dfinity/data-params.as index c47ad52ce98..b4f94319050 100644 --- a/test/run-dfinity/data-params.as +++ b/test/run-dfinity/data-params.as @@ -10,7 +10,7 @@ let a = actor { printInt(c); print("\n"); }; - incnested(n1 : Nat, (n2 : Nat, n3: Nat)) : () { + incnested(n1 : Nat, (n2 : Nat, n3 : Nat)) : () { c += n1 + n2 + n3; printInt(c); print("\n"); @@ -43,8 +43,10 @@ let a = actor { printInt(c); print("\n"); }; - readCounter(f : shared Nat -> ()) : () { - f(c); + printLabeledOpt(?l:?Text) { + print l; + printInt(c); + print("\n"); }; }; @@ -63,5 +65,149 @@ a.incopt(?14); a.increcord(shared {x = 15; y = 16}); a.increcord(shared {x = 17; y = 18; z = 19}); a.printCounter(); -a.printLabeled("Foo: "); -// a.readCounter(func (n : Nat) = { printInt n; print("\n") }); +a.printLabeled("Foo1: "); +a.printLabeledOpt(?"Foo2: "); +a.incn(10000000000000); + + +let w32 = actor { + private var c : Word32 = 0; + incn(n : Word32) : () { + c += n; + printInt(word32ToInt(c)); + print("\n"); + }; + incnn(n1 : Word32, n2 : Word32) : () { + c += n1 + n2; + printInt(word32ToInt(c)); + print("\n"); + }; + incnested(n1 : Word32, (n2 : Word32, n3 : Word32)) : () { + c += n1 + n2 + n3; + printInt(word32ToInt(c)); + print("\n"); + }; + incarray(a : [Word32]) : () { + for (i in a.vals()) { c += i }; + printInt(word32ToInt(c)); + print("\n"); + }; + incopt(a : ?Word32) : () { + switch a { + case null { c += 1000000 }; + case (?a) { c += a }; + }; + printInt(word32ToInt(c)); + print("\n"); + }; + increcord(a : shared { x : Word32; y : Word32 }) : () { + c += a.x; + c += a.y; + printInt(word32ToInt(c)); + print("\n"); + }; + printCounter() { + printInt(word32ToInt(c)); + print("\n"); + }; + printLabeled(l:Text) { + print l; + printInt(word32ToInt(c)); + print("\n"); + }; + printLabeledOpt(?l:?Text) { + print l; + printInt(word32ToInt(c)); + print("\n"); + }; +}; + + +w32.incn(1); +w32.incn(2); +w32.incn(3); +w32.incn(4); +w32.incn(1000); +w32.incnn(5,6); +w32.incnn(2000,3000); +w32.incnested(7,(8,9)); +w32.incarray([10,11,12,13]); +w32.incopt(null); +w32.incopt(?14); +w32.increcord(shared {x = 15 : Word32; y = 16 : Word32}); +w32.increcord(shared {x = 17 : Word32; y = 18 : Word32; z = 19 : Word32}); +w32.printCounter(); +w32.printLabeled("Foo1: "); +w32.printLabeledOpt(?"Foo2: "); + + + +let w16 = actor { + private var c : Word16 = 0; + incn(n : Word16) : () { + c += n; + printInt(word16ToInt(c)); + print("\n"); + }; + incnn(n1 : Word16, n2 : Word16) : () { + c += n1 + n2; + printInt(word16ToInt(c)); + print("\n"); + }; + incnested(n1 : Word16, (n2 : Word16, n3 : Word16)) : () { + c += n1 + n2 + n3; + printInt(word16ToInt(c)); + print("\n"); + }; + incarray(a : [Word16]) : () { + for (i in a.vals()) { c += i }; + printInt(word16ToInt(c)); + print("\n"); + }; + incopt(a : ?Word16) : () { + switch a { + case null { c += 10000 }; + case (?a) { c += a }; + }; + printInt(word16ToInt(c)); + print("\n"); + }; + increcord(a : shared { x : Word16; y : Word16 }) : () { + c += a.x; + c += a.y; + printInt(word16ToInt(c)); + print("\n"); + }; + printCounter() { + printInt(word16ToInt(c)); + print("\n"); + }; + printLabeled(l:Text) { + print l; + printInt(word16ToInt(c)); + print("\n"); + }; + printLabeledOpt(?l:?Text) { + print l; + printInt(word16ToInt(c)); + print("\n"); + }; +}; + + +w16.incn(1); +w16.incn(2); +w16.incn(3); +w16.incn(4); +w16.incn(1000); +w16.incnn(5,6); +w16.incnn(2000,3000); +w16.incnested(7,(8,9)); +w16.incarray([10,11,12,13]); +w16.incopt(null); +w16.incopt(?14); +w16.increcord(shared {x = 15 : Word16; y = 16 : Word16}); +w16.increcord(shared {x = 17 : Word16; y = 18 : Word16; z = 19 : Word16}); +w16.printCounter(); +w16.printLabeled("Foo1: "); +w16.printLabeledOpt(?"Foo2: "); diff --git a/test/run-dfinity/hello-world-message.as b/test/run-dfinity/hello-world-message.as new file mode 100644 index 00000000000..5ea1e82608e --- /dev/null +++ b/test/run-dfinity/hello-world-message.as @@ -0,0 +1,7 @@ +actor { + hello () { + print("Hello World!\n"); + } +} + +//CALL hello diff --git a/test/run-dfinity/nary-async.as b/test/run-dfinity/nary-async.as index 3d7009061a6..5f2ae4c65c4 100644 --- a/test/run-dfinity/nary-async.as +++ b/test/run-dfinity/nary-async.as @@ -121,6 +121,7 @@ let _ : async (Int,) = async { */ +/* Disabled: No generic messages are supported func Generic(t:Text, x:T,eq:(T,T)->Bool) { shared func fu_u(x:T) : async T { @@ -143,3 +144,4 @@ Generic<()>("<()>\n", (), func eq(i:(),j:()) : Bool = true); Generic<(Int,Bool)>("<(Int,Bool)>\n", (1,true), func eq((i,b):(Int,Bool), (j,c):(Int,Bool)) : Bool = i == j and b == c); +*/ diff --git a/test/run-dfinity/no-boxed-references.as b/test/run-dfinity/no-boxed-references.as new file mode 100644 index 00000000000..95003e5e9e9 --- /dev/null +++ b/test/run-dfinity/no-boxed-references.as @@ -0,0 +1,13 @@ +// No unboxing between the start of foo and the call to serialize +// CHECK: (func $foo +// CHECK-NOT: box_reference +// CHECK: call $@deserialize +shared func foo(a : Text, b: Int) {}; + +// No boxing between the call to serialize and the indirect call +// CHECK: (func $start +// CHECK: call $@serialize +// CHECK-NOT: box_reference +// CHECK: call_indirect +foo("a", 42); + diff --git a/test/run-dfinity/ok/AST-64.dvm-run.ok b/test/run-dfinity/ok/AST-64.dvm-run.ok deleted file mode 100644 index 3b7e66c4381..00000000000 --- a/test/run-dfinity/ok/AST-64.dvm-run.ok +++ /dev/null @@ -1 +0,0 @@ -Top-level code done. diff --git a/test/run-dfinity/ok/AST-66.dvm-run.ok b/test/run-dfinity/ok/AST-66.dvm-run.ok deleted file mode 100644 index 3b7e66c4381..00000000000 --- a/test/run-dfinity/ok/AST-66.dvm-run.ok +++ /dev/null @@ -1 +0,0 @@ -Top-level code done. diff --git a/test/run-dfinity/ok/actor-reexport.dvm-run.ok b/test/run-dfinity/ok/actor-reexport.dvm-run.ok index 3292a97eddf..86607643126 100644 --- a/test/run-dfinity/ok/actor-reexport.dvm-run.ok +++ b/test/run-dfinity/ok/actor-reexport.dvm-run.ok @@ -1 +1 @@ -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: calling start failed with trap message: Uncaught RuntimeError: unreachable diff --git a/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok b/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok index 4a1af3b7fa5..e9abc3dcbac 100644 --- a/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok +++ b/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok @@ -1,2 +1,2 @@ -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable -Top-level code done. +W, hypervisor: calling func$98 failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: calling func$104 failed with trap message: Uncaught RuntimeError: unreachable diff --git a/test/run-dfinity/ok/async-loop-while.dvm-run.ok b/test/run-dfinity/ok/async-loop-while.dvm-run.ok index 48962aa5514..ac6ac408923 100644 --- a/test/run-dfinity/ok/async-loop-while.dvm-run.ok +++ b/test/run-dfinity/ok/async-loop-while.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. 012345678910012345678910012345678910012345678910 diff --git a/test/run-dfinity/ok/async-loop.dvm-run.ok b/test/run-dfinity/ok/async-loop.dvm-run.ok index 48962aa5514..ac6ac408923 100644 --- a/test/run-dfinity/ok/async-loop.dvm-run.ok +++ b/test/run-dfinity/ok/async-loop.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. 012345678910012345678910012345678910012345678910 diff --git a/test/run-dfinity/ok/async-new-obj.dvm-run.ok b/test/run-dfinity/ok/async-new-obj.dvm-run.ok index 7e362ebf28b..9dfdfbb5120 100644 --- a/test/run-dfinity/ok/async-new-obj.dvm-run.ok +++ b/test/run-dfinity/ok/async-new-obj.dvm-run.ok @@ -1,4 +1,3 @@ -Top-level code done. aaab babb cacb diff --git a/test/run-dfinity/ok/async-obj-mut.dvm-run.ok b/test/run-dfinity/ok/async-obj-mut.dvm-run.ok index 4adf0505adb..98f29c526f9 100644 --- a/test/run-dfinity/ok/async-obj-mut.dvm-run.ok +++ b/test/run-dfinity/ok/async-obj-mut.dvm-run.ok @@ -1,4 +1,3 @@ -Top-level code done. 123 done creating 345 diff --git a/test/run-dfinity/ok/async-while.dvm-run.ok b/test/run-dfinity/ok/async-while.dvm-run.ok index 48962aa5514..ac6ac408923 100644 --- a/test/run-dfinity/ok/async-while.dvm-run.ok +++ b/test/run-dfinity/ok/async-while.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. 012345678910012345678910012345678910012345678910 diff --git a/test/run-dfinity/ok/chat.dvm-run.ok b/test/run-dfinity/ok/chat.dvm-run.ok index 14b104cf323..40f6822b967 100644 --- a/test/run-dfinity/ok/chat.dvm-run.ok +++ b/test/run-dfinity/ok/chat.dvm-run.ok @@ -1,4 +1,3 @@ -Top-level code done. bob received hello from bob bob received goodbye from bob alice received hello from alice diff --git a/test/run-dfinity/ok/chatpp.dvm-run.ok b/test/run-dfinity/ok/chatpp.dvm-run.ok index 308b1aac58e..42e2059e8d8 100644 --- a/test/run-dfinity/ok/chatpp.dvm-run.ok +++ b/test/run-dfinity/ok/chatpp.dvm-run.ok @@ -1,4 +1,3 @@ -Top-level code done. (unsubscribe 0) (unsubscribe 1) (unsubscribe 2) diff --git a/test/run-dfinity/ok/closure-params.dvm-run.ok b/test/run-dfinity/ok/closure-params.dvm-run.ok index ebca8e760cd..17b4c77d5c9 100644 --- a/test/run-dfinity/ok/closure-params.dvm-run.ok +++ b/test/run-dfinity/ok/closure-params.dvm-run.ok @@ -1,4 +1,3 @@ -Top-level code done. 1 1 3 diff --git a/test/run-dfinity/ok/counter-class.dvm-run.ok b/test/run-dfinity/ok/counter-class.dvm-run.ok index 3292a97eddf..86607643126 100644 --- a/test/run-dfinity/ok/counter-class.dvm-run.ok +++ b/test/run-dfinity/ok/counter-class.dvm-run.ok @@ -1 +1 @@ -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: calling start failed with trap message: Uncaught RuntimeError: unreachable diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 0e471e1e485..024d434dd75 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -6,7 +6,6 @@ non-closed actor: (ActorE (FuncE dec (shared 0 -> 0) - (TupP) () (BlockE (LetD WildP (CallE ( 1 -> 0) (VarE show) (VarE c))) @@ -19,25 +18,39 @@ non-closed actor: (ActorE (FuncE read (shared 1 -> 0) - (VarP $1) + (params $k/0/raw) () (BlockE - (LetD (TupP) (TupE)) + (LetD + (TupP (VarP $k/0)) + (TupE + (CallE + ( 1 -> 1) + (PrimE @deserialize) + shared (serialized Int) -> () + (VarE $k/0/raw) + ) + ) + ) (CallE ( 1 -> 0) (FuncE $lambda ( 1 -> 0) - (VarP $0) + (params $cont/0) () - (CallE ( 1 -> 0) (VarE $0) (VarE c)) + (CallE ( 1 -> 0) (VarE $cont/0) (VarE c)) ) (FuncE $lambda ( 1 -> 0) - (VarP $2) + (params $y/0) () - (CallE (shared 1 -> 0) (VarE $1) (VarE $2)) + (CallE + (shared 1 -> 0) + (VarE $k/0) + (CallE ( 1 -> 1) (PrimE @serialize) Int (VarE $y/0)) + ) ) ) ) @@ -45,5 +58,5 @@ non-closed actor: (ActorE ) (read read) (dec dec) - actor {dec : shared () -> (); read : shared (shared Int -> ()) -> ()} + actor {dec : shared () -> (); read : shared (serialized shared (serialized Int) -> ()) -> ()} ) diff --git a/test/run-dfinity/ok/counter.dvm-run.ok b/test/run-dfinity/ok/counter.dvm-run.ok index a3480e087a1..dc01807c8fe 100644 --- a/test/run-dfinity/ok/counter.dvm-run.ok +++ b/test/run-dfinity/ok/counter.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. 2344 diff --git a/test/run-dfinity/ok/data-params.dvm-run.ok b/test/run-dfinity/ok/data-params.dvm-run.ok index 26d329b39b0..9a40c228b71 100644 --- a/test/run-dfinity/ok/data-params.dvm-run.ok +++ b/test/run-dfinity/ok/data-params.dvm-run.ok @@ -1,4 +1,3 @@ -Top-level code done. 1 3 6 @@ -13,4 +12,38 @@ Top-level code done. 1006136 1006171 1006171 -Foo: 1006171 +Foo1: 1006171 +Foo2: 1006171 +1317141083 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +1006091 +1006105 +1006136 +1006171 +1006171 +Foo1: 1006171 +Foo2: 1006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +16091 +16105 +16136 +16171 +16171 +Foo1: 16171 +Foo2: 16171 diff --git a/test/run-dfinity/ok/data-params.run-ir.ok b/test/run-dfinity/ok/data-params.run-ir.ok index e77c77a5d0a..1438d09752b 100644 --- a/test/run-dfinity/ok/data-params.run-ir.ok +++ b/test/run-dfinity/ok/data-params.run-ir.ok @@ -1,3 +1,6 @@ +data-params.as:46.18-46.28: warning, this pattern does not cover all possible values +data-params.as:118.18-118.28: warning, this pattern does not cover all possible values +data-params.as:190.18-190.28: warning, this pattern does not cover all possible values 1 3 6 @@ -12,4 +15,38 @@ 1006136 1006171 1006171 -Foo: 1006171 +Foo1: 1006171 +Foo2: 1006171 +10000001006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +1006091 +1006105 +1006136 +1006171 +1006171 +Foo1: 1006171 +Foo2: 1006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +16091 +16105 +16136 +16171 +16171 +Foo1: 16171 +Foo2: 16171 diff --git a/test/run-dfinity/ok/data-params.run-low.ok b/test/run-dfinity/ok/data-params.run-low.ok index e77c77a5d0a..1438d09752b 100644 --- a/test/run-dfinity/ok/data-params.run-low.ok +++ b/test/run-dfinity/ok/data-params.run-low.ok @@ -1,3 +1,6 @@ +data-params.as:46.18-46.28: warning, this pattern does not cover all possible values +data-params.as:118.18-118.28: warning, this pattern does not cover all possible values +data-params.as:190.18-190.28: warning, this pattern does not cover all possible values 1 3 6 @@ -12,4 +15,38 @@ 1006136 1006171 1006171 -Foo: 1006171 +Foo1: 1006171 +Foo2: 1006171 +10000001006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +1006091 +1006105 +1006136 +1006171 +1006171 +Foo1: 1006171 +Foo2: 1006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +16091 +16105 +16136 +16171 +16171 +Foo1: 16171 +Foo2: 16171 diff --git a/test/run-dfinity/ok/data-params.run.ok b/test/run-dfinity/ok/data-params.run.ok index e77c77a5d0a..1438d09752b 100644 --- a/test/run-dfinity/ok/data-params.run.ok +++ b/test/run-dfinity/ok/data-params.run.ok @@ -1,3 +1,6 @@ +data-params.as:46.18-46.28: warning, this pattern does not cover all possible values +data-params.as:118.18-118.28: warning, this pattern does not cover all possible values +data-params.as:190.18-190.28: warning, this pattern does not cover all possible values 1 3 6 @@ -12,4 +15,38 @@ 1006136 1006171 1006171 -Foo: 1006171 +Foo1: 1006171 +Foo2: 1006171 +10000001006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +1006091 +1006105 +1006136 +1006171 +1006171 +Foo1: 1006171 +Foo2: 1006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +16091 +16105 +16136 +16171 +16171 +Foo1: 16171 +Foo2: 16171 diff --git a/test/run-dfinity/ok/data-params.tc.ok b/test/run-dfinity/ok/data-params.tc.ok new file mode 100644 index 00000000000..8606a83e6af --- /dev/null +++ b/test/run-dfinity/ok/data-params.tc.ok @@ -0,0 +1,3 @@ +data-params.as:46.18-46.28: warning, this pattern does not cover all possible values +data-params.as:118.18-118.28: warning, this pattern does not cover all possible values +data-params.as:190.18-190.28: warning, this pattern does not cover all possible values diff --git a/test/run-dfinity/ok/data-params.wasm.stderr.ok b/test/run-dfinity/ok/data-params.wasm.stderr.ok new file mode 100644 index 00000000000..8606a83e6af --- /dev/null +++ b/test/run-dfinity/ok/data-params.wasm.stderr.ok @@ -0,0 +1,3 @@ +data-params.as:46.18-46.28: warning, this pattern does not cover all possible values +data-params.as:118.18-118.28: warning, this pattern does not cover all possible values +data-params.as:190.18-190.28: warning, this pattern does not cover all possible values diff --git a/test/run-dfinity/ok/empty-actor.dvm-run.ok b/test/run-dfinity/ok/empty-actor.dvm-run.ok deleted file mode 100644 index 3b7e66c4381..00000000000 --- a/test/run-dfinity/ok/empty-actor.dvm-run.ok +++ /dev/null @@ -1 +0,0 @@ -Top-level code done. diff --git a/test/run-dfinity/ok/fac.dvm-run.ok b/test/run-dfinity/ok/fac.dvm-run.ok index 6332b8b5e87..52bd8e43afb 100644 --- a/test/run-dfinity/ok/fac.dvm-run.ok +++ b/test/run-dfinity/ok/fac.dvm-run.ok @@ -1 +1 @@ -120Top-level code done. +120 diff --git a/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok b/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok index b9d940dfe06..4c1b1bd6651 100644 --- a/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok +++ b/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok @@ -1,7 +1,5 @@ -# -# Fatal error in v8::ToLocalChecked -# Empty MaybeLocal. -# - -dvm.sh: line 12: Illegal instruction dvm $@ +first-order +,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, +higher-order +,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, diff --git a/test/run-dfinity/ok/generic-tail-rec.dvm-run.ok b/test/run-dfinity/ok/generic-tail-rec.dvm-run.ok index 1cfb8645d12..6d96c93ceef 100644 --- a/test/run-dfinity/ok/generic-tail-rec.dvm-run.ok +++ b/test/run-dfinity/ok/generic-tail-rec.dvm-run.ok @@ -2,4 +2,3 @@ done 1 done 2 done 3 done 4 -Top-level code done. diff --git a/test/run-dfinity/ok/hello-concat-world.dvm-run.ok b/test/run-dfinity/ok/hello-concat-world.dvm-run.ok index 8d9d4c9eb23..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-concat-world.dvm-run.ok +++ b/test/run-dfinity/ok/hello-concat-world.dvm-run.ok @@ -1,2 +1 @@ Hello World! -Top-level code done. diff --git a/test/run-dfinity/ok/hello-world-async.dvm-run.ok b/test/run-dfinity/ok/hello-world-async.dvm-run.ok index 9c393e21691..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-world-async.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world-async.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. Hello World! diff --git a/test/run-dfinity/ok/hello-world-await.dvm-run.ok b/test/run-dfinity/ok/hello-world-await.dvm-run.ok index 9c393e21691..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-world-await.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world-await.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. Hello World! diff --git a/test/run-dfinity/ok/hello-world-message.dvm-run.ok b/test/run-dfinity/ok/hello-world-message.dvm-run.ok new file mode 100644 index 00000000000..f01f4492e8f --- /dev/null +++ b/test/run-dfinity/ok/hello-world-message.dvm-run.ok @@ -0,0 +1,2 @@ +DVM: Calling method hello +Hello World! diff --git a/test/run-dfinity/ok/hello-world.dvm-run.ok b/test/run-dfinity/ok/hello-world.dvm-run.ok index 8d9d4c9eb23..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-world.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world.dvm-run.ok @@ -1,2 +1 @@ Hello World! -Top-level code done. diff --git a/test/run-dfinity/ok/hello-world2.dvm-run.ok b/test/run-dfinity/ok/hello-world2.dvm-run.ok index 9c393e21691..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-world2.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world2.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. Hello World! diff --git a/test/run-dfinity/ok/hello-world3.dvm-run.ok b/test/run-dfinity/ok/hello-world3.dvm-run.ok index 9c393e21691..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-world3.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world3.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. Hello World! diff --git a/test/run-dfinity/ok/indirect-counter.dvm-run.ok b/test/run-dfinity/ok/indirect-counter.dvm-run.ok index a3480e087a1..dc01807c8fe 100644 --- a/test/run-dfinity/ok/indirect-counter.dvm-run.ok +++ b/test/run-dfinity/ok/indirect-counter.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. 2344 diff --git a/test/run-dfinity/ok/large-mem.dvm-run.ok b/test/run-dfinity/ok/large-mem.dvm-run.ok deleted file mode 100644 index 3b7e66c4381..00000000000 --- a/test/run-dfinity/ok/large-mem.dvm-run.ok +++ /dev/null @@ -1 +0,0 @@ -Top-level code done. diff --git a/test/run-dfinity/ok/nary-async.dvm-run.ok b/test/run-dfinity/ok/nary-async.dvm-run.ok index b4dbdd9a6ee..3df16532e56 100644 --- a/test/run-dfinity/ok/nary-async.dvm-run.ok +++ b/test/run-dfinity/ok/nary-async.dvm-run.ok @@ -1,4 +1,3 @@ -Top-level code done. 0_0 1_0 2_0 @@ -7,6 +6,4 @@ Top-level code done. 0_1 0_2 0_3 -!! -<()> -<(Int,Bool)> +!! diff --git a/test/run-dfinity/ok/nary-async.run-ir.ok b/test/run-dfinity/ok/nary-async.run-ir.ok index 5b2baf03eb2..3df16532e56 100644 --- a/test/run-dfinity/ok/nary-async.run-ir.ok +++ b/test/run-dfinity/ok/nary-async.run-ir.ok @@ -6,6 +6,4 @@ 0_1 0_2 0_3 -!! -<()> -<(Int,Bool)> +!! diff --git a/test/run-dfinity/ok/nary-async.run-low.ok b/test/run-dfinity/ok/nary-async.run-low.ok index 5b2baf03eb2..3df16532e56 100644 --- a/test/run-dfinity/ok/nary-async.run-low.ok +++ b/test/run-dfinity/ok/nary-async.run-low.ok @@ -6,6 +6,4 @@ 0_1 0_2 0_3 -!! -<()> -<(Int,Bool)> +!! diff --git a/test/run-dfinity/ok/nary-async.run.ok b/test/run-dfinity/ok/nary-async.run.ok index 5b2baf03eb2..3df16532e56 100644 --- a/test/run-dfinity/ok/nary-async.run.ok +++ b/test/run-dfinity/ok/nary-async.run.ok @@ -6,6 +6,4 @@ 0_1 0_2 0_3 -!! -<()> -<(Int,Bool)> +!! diff --git a/test/run-dfinity/ok/overflow.dvm-run.ok b/test/run-dfinity/ok/overflow.dvm-run.ok index 501d4e74886..63e039d9bb0 100644 --- a/test/run-dfinity/ok/overflow.dvm-run.ok +++ b/test/run-dfinity/ok/overflow.dvm-run.ok @@ -1,5 +1,5 @@ -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable -Top-level code done. +W, hypervisor: calling func$110 failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: calling func$116 failed with trap message: Uncaught RuntimeError: unreachable This is reachable. This is reachable. This is reachable. diff --git a/test/run-dfinity/ok/reference-params.dvm-run.ok b/test/run-dfinity/ok/reference-params.dvm-run.ok index 9a57656f7a1..8650e0ef3bf 100644 --- a/test/run-dfinity/ok/reference-params.dvm-run.ok +++ b/test/run-dfinity/ok/reference-params.dvm-run.ok @@ -1,4 +1,3 @@ -Top-level code done. Hello World! Hello World! Hello World! diff --git a/test/run-dfinity/ok/selftail.dvm-run.ok b/test/run-dfinity/ok/selftail.dvm-run.ok index d58ee786174..acb397e19f2 100644 --- a/test/run-dfinity/ok/selftail.dvm-run.ok +++ b/test/run-dfinity/ok/selftail.dvm-run.ok @@ -1,3 +1,2 @@ ok1 ok2 -Top-level code done. diff --git a/test/run-dfinity/ok/tailpositions.dvm-run.ok b/test/run-dfinity/ok/tailpositions.dvm-run.ok index a0ef19cc3e9..025c12b0e9a 100644 --- a/test/run-dfinity/ok/tailpositions.dvm-run.ok +++ b/test/run-dfinity/ok/tailpositions.dvm-run.ok @@ -5,4 +5,3 @@ done 4 done 5 done 6 done 7 -Top-level code done. diff --git a/test/run-dfinity/ok/the-answer.dvm-run.ok b/test/run-dfinity/ok/the-answer.dvm-run.ok index 911d4f5b36f..d81cc0710eb 100644 --- a/test/run-dfinity/ok/the-answer.dvm-run.ok +++ b/test/run-dfinity/ok/the-answer.dvm-run.ok @@ -1 +1 @@ -42Top-level code done. +42 diff --git a/test/run.sh b/test/run.sh index 118a14c23d9..e922b3bc660 100755 --- a/test/run.sh +++ b/test/run.sh @@ -8,9 +8,10 @@ # # -a: Update the files in ok/ # -d: Compile with --dfinity, use dvm to run +# -s: Be silent in sunny-day execution # -realpath() { +function realpath() { [[ $1 = /* ]] && echo "$1" || echo "$PWD/${1#./}" } @@ -78,7 +79,7 @@ do [ -d $out ] || mkdir $out [ -d $ok ] || mkdir $ok - rm -f $out/$base.{tc,wasm,wasm.map,wasm-run,dvm-run} + rm -f $out/$base.{tc,wasm,wasm.map,wasm-run,dvm-run,filecheck,diff-ir,diff-low} # First run all the steps, and remember what to diff diff_files= @@ -100,16 +101,6 @@ do normalize $out/$base.run diff_files="$diff_files $base.run" - # Interpret with lowering - $ECHO -n " [run-low]" - $ASC $ASC_FLAGS -r -a -A $base.as > $out/$base.run-low 2>&1 - normalize $out/$base.run-low - diff_files="$diff_files $base.run-low" - - # Diff interpretations without/with lowering - diff -u -N --label "$base.run" $out/$base.run --label "$base.run-low" $out/$base.run-low > $out/$base.diff-low - diff_files="$diff_files $base.diff-low" - # Interpret IR $ECHO -n " [run-ir]" $ASC $ASC_FLAGS -r -iR $base.as > $out/$base.run-ir 2>&1 @@ -119,19 +110,37 @@ do # Diff interpretations without/with lowering diff -u -N --label "$base.run" $out/$base.run --label "$base.run-ir" $out/$base.run-ir > $out/$base.diff-ir diff_files="$diff_files $base.diff-ir" + + # Interpret IR with lowering + $ECHO -n " [run-low]" + $ASC $ASC_FLAGS -r -iR -a -A $base.as > $out/$base.run-low 2>&1 + normalize $out/$base.run-low + diff_files="$diff_files $base.run-low" + + # Diff interpretations without/with lowering + diff -u -N --label "$base.run" $out/$base.run --label "$base.run-low" $out/$base.run-low > $out/$base.diff-low + diff_files="$diff_files $base.diff-low" + fi # Compile $ECHO -n " [wasm]" - if [ $DFINITY = 'yes' ] - then - $ASC $ASC_FLAGS $EXTRA_ASC_FLAGS --map -c $base.as <(echo 'print("Top-level code done.\n")') -o $out/$base.wasm 2> $out/$base.wasm.stderr - else - $ASC $ASC_FLAGS $EXTRA_ASC_FLAGS --map -c $base.as -o $out/$base.wasm 2> $out/$base.wasm.stderr - fi + $ASC $ASC_FLAGS $EXTRA_ASC_FLAGS --map -c $base.as -o $out/$base.wasm 2> $out/$base.wasm.stderr normalize $out/$base.wasm.stderr diff_files="$diff_files $base.wasm.stderr" + # Check filecheck + if [ "$SKIP_RUNNING" != yes ] + then + if grep -F -q CHECK $base.as + then + $ECHO -n " [FileCheck]" + wasm2wat --no-check --enable-multi-value $out/$base.wasm > $out/$base.wat + cat $out/$base.wat | FileCheck $base.as > $out/$base.filecheck 2>&1 + diff_files="$diff_files $base.filecheck" + fi + fi + # Run compiled program if [ -e $out/$base.wasm ] then @@ -140,7 +149,7 @@ do if [ $DFINITY = 'yes' ] then $ECHO -n " [dvm]" - $DVM_WRAPPER $out/$base.wasm > $out/$base.dvm-run 2>&1 + $DVM_WRAPPER $out/$base.wasm $base.as > $out/$base.dvm-run 2>&1 normalize $out/$base.dvm-run diff_files="$diff_files $base.dvm-run" else diff --git a/test/run/asyncreturn.as b/test/run/asyncreturn.as deleted file mode 100644 index 177e40c68d7..00000000000 --- a/test/run/asyncreturn.as +++ /dev/null @@ -1,18 +0,0 @@ -// works -func call1(f : shared () -> ()) : () { f(); }; -func call2(f : shared () -> async B) : async B { await f(); }; -// does not work -// func call3(f : shared () -> C) : C { f (); }; - -let a = actor { get42() : async Nat = async { 42 }; }; -let _ = async { printInt(await (call2(a.get42))); }; - - -//func call3(f : shared () -> async B) : async B { f(); }; - -func call3(f : shared () -> async B) : async B = f() ; - -// illegal: -// shared func call4(f : shared () -> async B) : async B = f() ; - -shared func call4(f : shared () -> async B) : async B = async await f() ; \ No newline at end of file diff --git a/test/run/control.as b/test/run/control.as index f742c71e46b..a4eeab3dbc9 100644 --- a/test/run/control.as +++ b/test/run/control.as @@ -1,6 +1,6 @@ actor class Control() { - private condition() : Bool = false; + private condition() : Bool = false; testBlock() { label l1 { @@ -25,7 +25,7 @@ actor class Control() { else continue l; }; }; - + testLoopWhile() { label l loop { if true break l @@ -33,6 +33,22 @@ actor class Control() { } while (condition()); }; + testLoopWhile2() { + loop { } while (false); + }; + + testLoopWhile3() { + label l { + loop { } + while (false and true) + }; + }; + + testLoopWhile4() { + label l loop { + } while (true and false); + }; + testNestedWhile() { label l while (condition()) { if true break l diff --git a/test/run/conversions.as b/test/run/conversions.as index 35feabe47ec..472dd48517c 100644 --- a/test/run/conversions.as +++ b/test/run/conversions.as @@ -135,3 +135,33 @@ println(word32ToInt 4294967295); // == (-1) // 2**32 - 1 roundtrip (-100000000); roundtrip (-1000000000); }; + + + + +// Char <--> Word32 + +assert(charToWord32 '\u{00}' == (0 : Word32)); +assert(charToWord32 '*' == (42 : Word32)); +assert(charToWord32 'П' == (1055 : Word32)); +assert(charToWord32 '\u{ffff}' == (65535 : Word32)); // 2**16 - 1 +assert(charToWord32 '\u{10ffff}' == (0x10FFFF : Word32)); + +{ + func roundtrip(w : Word32) = assert (charToWord32 (word32ToChar w) == w); + roundtrip 0; + roundtrip 10; + roundtrip 100; + roundtrip 1000; + roundtrip 10000; + roundtrip 100000; + roundtrip 1000000; + roundtrip 0x10FFFF; // largest code point +}; + + +// Char <--> Text + +assert(charToText 'П' == "П"); +func snd((a : Word32, b : Char)) : Char = b; +assert(snd (decodeUTF8 "П") =='П'); diff --git a/test/run/hashes.as b/test/run/hashes.as new file mode 100644 index 00000000000..eed93e35d45 --- /dev/null +++ b/test/run/hashes.as @@ -0,0 +1,8 @@ + +assert (hashInt (10**7) == (10000000 : Word32)); +assert (hashInt 0 == (0 : Word32)); +assert (hashInt (10**18) == (2_860_824_243 : Word32)); + +assert (hashInt (-1) == (0 : Word32)); +assert (hashInt (-387) == (386 : Word32)); +assert (hashInt (-3876548352991) == (2_487_851_096 : Word32)); diff --git a/test/run/literals.as b/test/run/literals.as index 42060c4348f..b87c333bc96 100644 --- a/test/run/literals.as +++ b/test/run/literals.as @@ -6,4 +6,7 @@ let byte : Word8 = 0xFF : Word8; let short : Word16 = 0xFFFF : Word16; let word : Word32 = 0xFFFF_FFFF : Word32; let u = '\u{a34}'; +let gu = '🎸'; +let ru = "Приветствую, мир!\n"; let s = "a \t\22\00bb\'bc\\de \74xx\\x\"\u{000_234_42}\n"; +let emojis = "🙈🎸😋"; diff --git a/test/run/mutrec2.as b/test/run/mutrec2.as index 2b80d8dee4a..4238b383cd7 100644 --- a/test/run/mutrec2.as +++ b/test/run/mutrec2.as @@ -1,19 +1,27 @@ -var sub = 1; - func even(n : Nat) : Bool { if (n == 0) { return true; } else - return odd(n-sub); + return odd(n-1); }; func odd(n : Nat) : Bool { if (n == 0) { return false; } else - return even(n-sub); + return even(n-1); }; +// There should be a bunch of calls to known functions here, but +// no indirect calls +// CHECK: func $start +// CHECK: call $even +// CHECK: call $even +// CHECK: call $even +// CHECK: call $even +// CHECK: call $odd +// CHECK: call $odd + assert(even(0)); assert(even(2)); assert(even(4)); diff --git a/test/run/ok/asyncreturn.run-ir.ok b/test/run/ok/asyncreturn.run-ir.ok deleted file mode 100644 index d81cc0710eb..00000000000 --- a/test/run/ok/asyncreturn.run-ir.ok +++ /dev/null @@ -1 +0,0 @@ -42 diff --git a/test/run/ok/asyncreturn.run-low.ok b/test/run/ok/asyncreturn.run-low.ok deleted file mode 100644 index d81cc0710eb..00000000000 --- a/test/run/ok/asyncreturn.run-low.ok +++ /dev/null @@ -1 +0,0 @@ -42 diff --git a/test/run/ok/asyncreturn.run.ok b/test/run/ok/asyncreturn.run.ok deleted file mode 100644 index d81cc0710eb..00000000000 --- a/test/run/ok/asyncreturn.run.ok +++ /dev/null @@ -1 +0,0 @@ -42 diff --git a/test/run/ok/asyncreturn.wasm-run.ok b/test/run/ok/asyncreturn.wasm-run.ok deleted file mode 100644 index 0b80fcc95f3..00000000000 --- a/test/run/ok/asyncreturn.wasm-run.ok +++ /dev/null @@ -1 +0,0 @@ -_out/asyncreturn.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/bit-ops.wasm.stderr.ok b/test/run/ok/bit-ops.wasm.stderr.ok deleted file mode 100644 index 2a9d2f8f16e..00000000000 --- a/test/run/ok/bit-ops.wasm.stderr.ok +++ /dev/null @@ -1,106 +0,0 @@ -compile_unop: NotOp -compile_unop: NotOp -compile_binop: OrOp -of_type: Word8 -compile_binop: OrOp -of_type: Word8 -compile_binop: AndOp -of_type: Word8 -compile_binop: AndOp -of_type: Word8 -compile_binop: XorOp -of_type: Word8 -compile_binop: XorOp -of_type: Word8 -compile_binop: ShiftLOp -of_type: Word8 -compile_binop: ShiftLOp -of_type: Word8 -compile_binop: ShiftROp -of_type: Word8 -compile_binop: ShiftROp -of_type: Word8 -compile_binop: RotLOp -of_type: Word8 -compile_binop: RotLOp -of_type: Word8 -compile_binop: RotROp -of_type: Word8 -compile_binop: RotROp -of_type: Word8 -compile_unop: NotOp -compile_unop: NotOp -compile_binop: OrOp -of_type: Word16 -compile_binop: OrOp -of_type: Word16 -compile_binop: AndOp -of_type: Word16 -compile_binop: AndOp -of_type: Word16 -compile_binop: XorOp -of_type: Word16 -compile_binop: XorOp -of_type: Word16 -compile_binop: ShiftLOp -of_type: Word16 -compile_binop: ShiftLOp -of_type: Word16 -compile_binop: ShiftROp -of_type: Word16 -compile_binop: ShiftROp -of_type: Word16 -compile_binop: RotLOp -of_type: Word16 -compile_binop: RotLOp -of_type: Word16 -compile_binop: RotROp -of_type: Word16 -compile_binop: RotROp -of_type: Word16 -compile_unop: NotOp -compile_unop: NotOp -compile_binop: OrOp -compile_binop: OrOp -compile_binop: AndOp -compile_binop: AndOp -compile_binop: XorOp -compile_binop: XorOp -compile_binop: ShiftLOp -compile_binop: ShiftLOp -compile_binop: ShiftROp -compile_binop: ShiftROp -compile_binop: RotLOp -compile_binop: RotLOp -compile_binop: RotROp -compile_binop: RotROp -compile_unop: NotOp -compile_unop: NotOp -compile_binop: OrOp -of_type: Word64 -compile_binop: OrOp -of_type: Word64 -compile_binop: AndOp -of_type: Word64 -compile_binop: AndOp -of_type: Word64 -compile_binop: XorOp -of_type: Word64 -compile_binop: XorOp -of_type: Word64 -compile_binop: ShiftLOp -of_type: Word64 -compile_binop: ShiftLOp -of_type: Word64 -compile_binop: ShiftROp -of_type: Word64 -compile_binop: ShiftROp -of_type: Word64 -compile_binop: RotLOp -of_type: Word64 -compile_binop: RotLOp -of_type: Word64 -compile_binop: RotROp -of_type: Word64 -compile_binop: RotROp -of_type: Word64 diff --git a/test/run/ok/coverage.run-ir.ok b/test/run/ok/coverage.run-ir.ok index b432a6df617..3e28522aedb 100644 --- a/test/run/ok/coverage.run-ir.ok +++ b/test/run/ok/coverage.run-ir.ok @@ -14,12 +14,12 @@ coverage.as:32.43-32.44: warning, this pattern is never matched coverage.as:33.35-33.49: warning, this case is never reached coverage.as:34.42-34.51: warning, this case is never reached coverage.as:4.7-4.8: warning, this pattern does not cover all possible values -coverage.as:5.8-5.14: warning, this pattern does not cover all possible values +coverage.as:5.7-5.15: warning, this pattern does not cover all possible values coverage.as:9.7-9.9: warning, this pattern does not cover all possible values coverage.as:10.7-10.9: warning, this pattern does not cover all possible values coverage.as:11.7-11.9: warning, this pattern does not cover all possible values -coverage.as:15.11-15.12: warning, this pattern does not cover all possible values -coverage.as:16.11-16.17: warning, this pattern does not cover all possible values +coverage.as:15.10-15.13: warning, this pattern does not cover all possible values +coverage.as:16.10-16.18: warning, this pattern does not cover all possible values coverage.as:23.3-23.25: warning, the cases in this switch do not cover all possible values coverage.as:24.3-24.36: warning, the cases in this switch do not cover all possible values coverage.as:32.3-32.50: warning, the cases in this switch do not cover all possible values diff --git a/test/run/ok/coverage.run-low.ok b/test/run/ok/coverage.run-low.ok index b432a6df617..3e28522aedb 100644 --- a/test/run/ok/coverage.run-low.ok +++ b/test/run/ok/coverage.run-low.ok @@ -14,12 +14,12 @@ coverage.as:32.43-32.44: warning, this pattern is never matched coverage.as:33.35-33.49: warning, this case is never reached coverage.as:34.42-34.51: warning, this case is never reached coverage.as:4.7-4.8: warning, this pattern does not cover all possible values -coverage.as:5.8-5.14: warning, this pattern does not cover all possible values +coverage.as:5.7-5.15: warning, this pattern does not cover all possible values coverage.as:9.7-9.9: warning, this pattern does not cover all possible values coverage.as:10.7-10.9: warning, this pattern does not cover all possible values coverage.as:11.7-11.9: warning, this pattern does not cover all possible values -coverage.as:15.11-15.12: warning, this pattern does not cover all possible values -coverage.as:16.11-16.17: warning, this pattern does not cover all possible values +coverage.as:15.10-15.13: warning, this pattern does not cover all possible values +coverage.as:16.10-16.18: warning, this pattern does not cover all possible values coverage.as:23.3-23.25: warning, the cases in this switch do not cover all possible values coverage.as:24.3-24.36: warning, the cases in this switch do not cover all possible values coverage.as:32.3-32.50: warning, the cases in this switch do not cover all possible values diff --git a/test/run/ok/coverage.run.ok b/test/run/ok/coverage.run.ok index b432a6df617..3e28522aedb 100644 --- a/test/run/ok/coverage.run.ok +++ b/test/run/ok/coverage.run.ok @@ -14,12 +14,12 @@ coverage.as:32.43-32.44: warning, this pattern is never matched coverage.as:33.35-33.49: warning, this case is never reached coverage.as:34.42-34.51: warning, this case is never reached coverage.as:4.7-4.8: warning, this pattern does not cover all possible values -coverage.as:5.8-5.14: warning, this pattern does not cover all possible values +coverage.as:5.7-5.15: warning, this pattern does not cover all possible values coverage.as:9.7-9.9: warning, this pattern does not cover all possible values coverage.as:10.7-10.9: warning, this pattern does not cover all possible values coverage.as:11.7-11.9: warning, this pattern does not cover all possible values -coverage.as:15.11-15.12: warning, this pattern does not cover all possible values -coverage.as:16.11-16.17: warning, this pattern does not cover all possible values +coverage.as:15.10-15.13: warning, this pattern does not cover all possible values +coverage.as:16.10-16.18: warning, this pattern does not cover all possible values coverage.as:23.3-23.25: warning, the cases in this switch do not cover all possible values coverage.as:24.3-24.36: warning, the cases in this switch do not cover all possible values coverage.as:32.3-32.50: warning, the cases in this switch do not cover all possible values diff --git a/test/run/ok/coverage.tc.ok b/test/run/ok/coverage.tc.ok index b432a6df617..3e28522aedb 100644 --- a/test/run/ok/coverage.tc.ok +++ b/test/run/ok/coverage.tc.ok @@ -14,12 +14,12 @@ coverage.as:32.43-32.44: warning, this pattern is never matched coverage.as:33.35-33.49: warning, this case is never reached coverage.as:34.42-34.51: warning, this case is never reached coverage.as:4.7-4.8: warning, this pattern does not cover all possible values -coverage.as:5.8-5.14: warning, this pattern does not cover all possible values +coverage.as:5.7-5.15: warning, this pattern does not cover all possible values coverage.as:9.7-9.9: warning, this pattern does not cover all possible values coverage.as:10.7-10.9: warning, this pattern does not cover all possible values coverage.as:11.7-11.9: warning, this pattern does not cover all possible values -coverage.as:15.11-15.12: warning, this pattern does not cover all possible values -coverage.as:16.11-16.17: warning, this pattern does not cover all possible values +coverage.as:15.10-15.13: warning, this pattern does not cover all possible values +coverage.as:16.10-16.18: warning, this pattern does not cover all possible values coverage.as:23.3-23.25: warning, the cases in this switch do not cover all possible values coverage.as:24.3-24.36: warning, the cases in this switch do not cover all possible values coverage.as:32.3-32.50: warning, the cases in this switch do not cover all possible values diff --git a/test/run/ok/coverage.wasm.stderr.ok b/test/run/ok/coverage.wasm.stderr.ok index b432a6df617..3e28522aedb 100644 --- a/test/run/ok/coverage.wasm.stderr.ok +++ b/test/run/ok/coverage.wasm.stderr.ok @@ -14,12 +14,12 @@ coverage.as:32.43-32.44: warning, this pattern is never matched coverage.as:33.35-33.49: warning, this case is never reached coverage.as:34.42-34.51: warning, this case is never reached coverage.as:4.7-4.8: warning, this pattern does not cover all possible values -coverage.as:5.8-5.14: warning, this pattern does not cover all possible values +coverage.as:5.7-5.15: warning, this pattern does not cover all possible values coverage.as:9.7-9.9: warning, this pattern does not cover all possible values coverage.as:10.7-10.9: warning, this pattern does not cover all possible values coverage.as:11.7-11.9: warning, this pattern does not cover all possible values -coverage.as:15.11-15.12: warning, this pattern does not cover all possible values -coverage.as:16.11-16.17: warning, this pattern does not cover all possible values +coverage.as:15.10-15.13: warning, this pattern does not cover all possible values +coverage.as:16.10-16.18: warning, this pattern does not cover all possible values coverage.as:23.3-23.25: warning, the cases in this switch do not cover all possible values coverage.as:24.3-24.36: warning, the cases in this switch do not cover all possible values coverage.as:32.3-32.50: warning, the cases in this switch do not cover all possible values diff --git a/test/run/ok/literals.wasm-run.ok b/test/run/ok/literals.wasm-run.ok deleted file mode 100644 index 11a148f71ae..00000000000 --- a/test/run/ok/literals.wasm-run.ok +++ /dev/null @@ -1 +0,0 @@ -_out/literals.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/literals.wasm.stderr.ok b/test/run/ok/literals.wasm.stderr.ok deleted file mode 100644 index db71b22da87..00000000000 --- a/test/run/ok/literals.wasm.stderr.ok +++ /dev/null @@ -1,3 +0,0 @@ -compile_lit: (Word8Lit 255) -compile_lit: (Word16Lit 6_5535) -compile_lit: (CharLit 2612) diff --git a/test/run/ok/numeric-ops.wasm.stderr.ok b/test/run/ok/numeric-ops.wasm.stderr.ok index 2230f1fa5ce..20555433169 100644 --- a/test/run/ok/numeric-ops.wasm.stderr.ok +++ b/test/run/ok/numeric-ops.wasm.stderr.ok @@ -1,13 +1,3 @@ -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_unop: PosOp -compile_unop: PosOp compile_unop: NegOp compile_unop: NegOp compile_binop: AddOp @@ -30,87 +20,3 @@ compile_binop: PowOp of_type: Float compile_binop: PowOp of_type: Float -compile_binop: AddOp -of_type: Word8 -compile_binop: AddOp -of_type: Word8 -compile_binop: SubOp -of_type: Word8 -compile_binop: SubOp -of_type: Word8 -compile_binop: MulOp -of_type: Word8 -compile_binop: MulOp -of_type: Word8 -compile_binop: DivOp -of_type: Word8 -compile_binop: DivOp -of_type: Word8 -compile_binop: ModOp -of_type: Word8 -compile_binop: ModOp -of_type: Word8 -compile_binop: PowOp -of_type: Word8 -compile_binop: PowOp -of_type: Word8 -compile_binop: AddOp -of_type: Word16 -compile_binop: AddOp -of_type: Word16 -compile_binop: SubOp -of_type: Word16 -compile_binop: SubOp -of_type: Word16 -compile_binop: MulOp -of_type: Word16 -compile_binop: MulOp -of_type: Word16 -compile_binop: DivOp -of_type: Word16 -compile_binop: DivOp -of_type: Word16 -compile_binop: ModOp -of_type: Word16 -compile_binop: ModOp -of_type: Word16 -compile_binop: PowOp -of_type: Word16 -compile_binop: PowOp -of_type: Word16 -compile_binop: AddOp -compile_binop: AddOp -compile_binop: SubOp -compile_binop: SubOp -compile_binop: MulOp -compile_binop: MulOp -compile_binop: DivOp -compile_binop: DivOp -compile_binop: ModOp -compile_binop: ModOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: AddOp -of_type: Word64 -compile_binop: AddOp -of_type: Word64 -compile_binop: SubOp -of_type: Word64 -compile_binop: SubOp -of_type: Word64 -compile_binop: MulOp -of_type: Word64 -compile_binop: MulOp -of_type: Word64 -compile_binop: DivOp -of_type: Word64 -compile_binop: DivOp -of_type: Word64 -compile_binop: ModOp -of_type: Word64 -compile_binop: ModOp -of_type: Word64 -compile_binop: PowOp -of_type: Word64 -compile_binop: PowOp -of_type: Word64 diff --git a/test/run/ok/relational-ops.wasm.stderr.ok b/test/run/ok/relational-ops.wasm.stderr.ok index 339785ac3b0..509dff09494 100644 --- a/test/run/ok/relational-ops.wasm.stderr.ok +++ b/test/run/ok/relational-ops.wasm.stderr.ok @@ -22,110 +22,6 @@ compile_relop: GeOp of_type: Float compile_relop: GeOp of_type: Float -compile_eq: EqOp -of_type: Word8 -compile_eq: EqOp -of_type: Word8 -compile_eq: EqOp -of_type: Word8 -compile_eq: EqOp -of_type: Word8 -compile_relop: LtOp -of_type: Word8 -compile_relop: LtOp -of_type: Word8 -compile_relop: LeOp -of_type: Word8 -compile_relop: LeOp -of_type: Word8 -compile_relop: GtOp -of_type: Word8 -compile_relop: GtOp -of_type: Word8 -compile_relop: GeOp -of_type: Word8 -compile_relop: GeOp -of_type: Word8 -compile_eq: EqOp -of_type: Word16 -compile_eq: EqOp -of_type: Word16 -compile_eq: EqOp -of_type: Word16 -compile_eq: EqOp -of_type: Word16 -compile_relop: LtOp -of_type: Word16 -compile_relop: LtOp -of_type: Word16 -compile_relop: LeOp -of_type: Word16 -compile_relop: LeOp -of_type: Word16 -compile_relop: GtOp -of_type: Word16 -compile_relop: GtOp -of_type: Word16 -compile_relop: GeOp -of_type: Word16 -compile_relop: GeOp -of_type: Word16 -compile_relop: LtOp -compile_relop: LtOp -compile_relop: LeOp -compile_relop: LeOp -compile_relop: GtOp -compile_relop: GtOp -compile_relop: GeOp -compile_relop: GeOp -compile_eq: EqOp -of_type: Word64 -compile_eq: EqOp -of_type: Word64 -compile_eq: EqOp -of_type: Word64 -compile_eq: EqOp -of_type: Word64 -compile_relop: LtOp -of_type: Word64 -compile_relop: LtOp -of_type: Word64 -compile_relop: LeOp -of_type: Word64 -compile_relop: LeOp -of_type: Word64 -compile_relop: GtOp -of_type: Word64 -compile_relop: GtOp -of_type: Word64 -compile_relop: GeOp -of_type: Word64 -compile_relop: GeOp -of_type: Word64 -compile_eq: EqOp -of_type: Char -compile_eq: EqOp -of_type: Char -compile_eq: EqOp -of_type: Char -compile_eq: EqOp -of_type: Char -compile_relop: LtOp -of_type: Char -compile_relop: LtOp -of_type: Char -compile_relop: LeOp -of_type: Char -compile_relop: LeOp -of_type: Char -compile_relop: GtOp -of_type: Char -compile_relop: GtOp -of_type: Char -compile_relop: GeOp -of_type: Char -compile_relop: GeOp -of_type: Char compile_relop: LtOp compile_relop: LtOp compile_relop: LeOp diff --git a/test/run/ok/text-iter.run-ir.ok b/test/run/ok/text-iter.run-ir.ok new file mode 100644 index 00000000000..5ac6300d553 --- /dev/null +++ b/test/run/ok/text-iter.run-ir.ok @@ -0,0 +1,20 @@ +via `print`: +hello world! + +via iteration and `printChar`: #1 +hello world! + +via iteration and `printChar`: #2 +1:'h' 2:'e' 3:'l' 4:'l' 5:'o' 6:' ' 7:'w' 8:'o' 9:'r' 10:'l' 11:'d' 12:'!' 13:' +' +via iteration and `printChar` (Unicode): #3 +1:'П' 2:'р' 3:'и' 4:'в' 5:'е' 6:'т' 7:'с' 8:'т' 9:'в' 10:'у' 11:'ю' 12:',' 13:' ' 14:'м' 15:'и' 16:'р' 17:'!' 18:' +' +via iteration and `printChar` (Unicode): #4 +1:'🙈' 2:'🎸' 3:'😋' +Приветствую, мир! + +2 +П +4 +🙈 diff --git a/test/run/ok/text-iter.run-low.ok b/test/run/ok/text-iter.run-low.ok new file mode 100644 index 00000000000..5ac6300d553 --- /dev/null +++ b/test/run/ok/text-iter.run-low.ok @@ -0,0 +1,20 @@ +via `print`: +hello world! + +via iteration and `printChar`: #1 +hello world! + +via iteration and `printChar`: #2 +1:'h' 2:'e' 3:'l' 4:'l' 5:'o' 6:' ' 7:'w' 8:'o' 9:'r' 10:'l' 11:'d' 12:'!' 13:' +' +via iteration and `printChar` (Unicode): #3 +1:'П' 2:'р' 3:'и' 4:'в' 5:'е' 6:'т' 7:'с' 8:'т' 9:'в' 10:'у' 11:'ю' 12:',' 13:' ' 14:'м' 15:'и' 16:'р' 17:'!' 18:' +' +via iteration and `printChar` (Unicode): #4 +1:'🙈' 2:'🎸' 3:'😋' +Приветствую, мир! + +2 +П +4 +🙈 diff --git a/test/run/ok/text-iter.run.ok b/test/run/ok/text-iter.run.ok new file mode 100644 index 00000000000..5ac6300d553 --- /dev/null +++ b/test/run/ok/text-iter.run.ok @@ -0,0 +1,20 @@ +via `print`: +hello world! + +via iteration and `printChar`: #1 +hello world! + +via iteration and `printChar`: #2 +1:'h' 2:'e' 3:'l' 4:'l' 5:'o' 6:' ' 7:'w' 8:'o' 9:'r' 10:'l' 11:'d' 12:'!' 13:' +' +via iteration and `printChar` (Unicode): #3 +1:'П' 2:'р' 3:'и' 4:'в' 5:'е' 6:'т' 7:'с' 8:'т' 9:'в' 10:'у' 11:'ю' 12:',' 13:' ' 14:'м' 15:'и' 16:'р' 17:'!' 18:' +' +via iteration and `printChar` (Unicode): #4 +1:'🙈' 2:'🎸' 3:'😋' +Приветствую, мир! + +2 +П +4 +🙈 diff --git a/test/run/ok/text-iter.wasm-run.ok b/test/run/ok/text-iter.wasm-run.ok new file mode 100644 index 00000000000..7033c807320 --- /dev/null +++ b/test/run/ok/text-iter.wasm-run.ok @@ -0,0 +1 @@ +_out/text-iter.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/words.run-ir.ok b/test/run/ok/words.run-ir.ok index e55f4fecf66..a3f996d1a6f 100644 --- a/test/run/ok/words.run-ir.ok +++ b/test/run/ok/words.run-ir.ok @@ -1,5 +1,30 @@ 8912765 8912765 +-8912765 -8912765 +-8912766 -8912766 +8917332 8917332 +8908198 8908198 +31969 31969 +652 652 +2548 2548 +20857489 20857489 +4437 4437 +8912895 8912895 +8908458 8908458 +584576 584576 +35 35 +-2 -2 +-326582449863721025 -326582449863721025 +1140833920 1140833920 +-432345564227497986 -432345564227497986 +61 61 +49 49 +5 5 +set +clear +set +8912765 8912765 4286054531 -8912765 +4286054530 -8912766 8917332 8917332 8908198 8908198 31969 31969 @@ -11,10 +36,19 @@ 8908458 8908458 584576 584576 35 35 +4294967294 -2 +4218928893 -76038403 1140833920 1140833920 4194373630 -100593666 +29 29 +17 17 +5 5 +set +clear +set 55734 -9802 9802 9802 +9801 9801 60301 -5235 51167 -14369 31969 31969 @@ -26,10 +60,18 @@ 51297 -14239 60288 -5248 35 35 +65534 -2 56172 -9364 28083 28083 +13 13 +1 1 +5 5 +set +clear +set 34 34 222 -34 +221 -35 101 101 223 -33 213 -43 @@ -41,5 +83,12 @@ 97 97 128 -128 0 0 +254 -2 17 17 68 68 +5 5 +0 0 +3 3 +set +clear +set diff --git a/test/run/ok/words.run-low.ok b/test/run/ok/words.run-low.ok index e55f4fecf66..a3f996d1a6f 100644 --- a/test/run/ok/words.run-low.ok +++ b/test/run/ok/words.run-low.ok @@ -1,5 +1,30 @@ 8912765 8912765 +-8912765 -8912765 +-8912766 -8912766 +8917332 8917332 +8908198 8908198 +31969 31969 +652 652 +2548 2548 +20857489 20857489 +4437 4437 +8912895 8912895 +8908458 8908458 +584576 584576 +35 35 +-2 -2 +-326582449863721025 -326582449863721025 +1140833920 1140833920 +-432345564227497986 -432345564227497986 +61 61 +49 49 +5 5 +set +clear +set +8912765 8912765 4286054531 -8912765 +4286054530 -8912766 8917332 8917332 8908198 8908198 31969 31969 @@ -11,10 +36,19 @@ 8908458 8908458 584576 584576 35 35 +4294967294 -2 +4218928893 -76038403 1140833920 1140833920 4194373630 -100593666 +29 29 +17 17 +5 5 +set +clear +set 55734 -9802 9802 9802 +9801 9801 60301 -5235 51167 -14369 31969 31969 @@ -26,10 +60,18 @@ 51297 -14239 60288 -5248 35 35 +65534 -2 56172 -9364 28083 28083 +13 13 +1 1 +5 5 +set +clear +set 34 34 222 -34 +221 -35 101 101 223 -33 213 -43 @@ -41,5 +83,12 @@ 97 97 128 -128 0 0 +254 -2 17 17 68 68 +5 5 +0 0 +3 3 +set +clear +set diff --git a/test/run/ok/words.run.ok b/test/run/ok/words.run.ok index e55f4fecf66..a3f996d1a6f 100644 --- a/test/run/ok/words.run.ok +++ b/test/run/ok/words.run.ok @@ -1,5 +1,30 @@ 8912765 8912765 +-8912765 -8912765 +-8912766 -8912766 +8917332 8917332 +8908198 8908198 +31969 31969 +652 652 +2548 2548 +20857489 20857489 +4437 4437 +8912895 8912895 +8908458 8908458 +584576 584576 +35 35 +-2 -2 +-326582449863721025 -326582449863721025 +1140833920 1140833920 +-432345564227497986 -432345564227497986 +61 61 +49 49 +5 5 +set +clear +set +8912765 8912765 4286054531 -8912765 +4286054530 -8912766 8917332 8917332 8908198 8908198 31969 31969 @@ -11,10 +36,19 @@ 8908458 8908458 584576 584576 35 35 +4294967294 -2 +4218928893 -76038403 1140833920 1140833920 4194373630 -100593666 +29 29 +17 17 +5 5 +set +clear +set 55734 -9802 9802 9802 +9801 9801 60301 -5235 51167 -14369 31969 31969 @@ -26,10 +60,18 @@ 51297 -14239 60288 -5248 35 35 +65534 -2 56172 -9364 28083 28083 +13 13 +1 1 +5 5 +set +clear +set 34 34 222 -34 +221 -35 101 101 223 -33 213 -43 @@ -41,5 +83,12 @@ 97 97 128 -128 0 0 +254 -2 17 17 68 68 +5 5 +0 0 +3 3 +set +clear +set diff --git a/test/run/ok/words.wasm.stderr.ok b/test/run/ok/words.wasm.stderr.ok deleted file mode 100644 index df2dd2439f9..00000000000 --- a/test/run/ok/words.wasm.stderr.ok +++ /dev/null @@ -1,79 +0,0 @@ -compile_binop: AddOp -compile_binop: SubOp -compile_binop: MulOp -compile_binop: DivOp -compile_binop: ModOp -compile_binop: PowOp -compile_binop: AndOp -compile_binop: OrOp -compile_binop: XorOp -compile_binop: ShiftLOp -compile_binop: ShiftROp -compile_binop: RotLOp -compile_binop: RotROp -compile_lit: (Word16Lit 4_567) -compile_lit: (Word16Lit 7) -compile_lit: (Word16Lit 5_5734) -compile_lit: (Word16Lit 15) -compile_lit: (Word16Lit 20_000) -compile_binop: AddOp -of_type: Word16 -compile_binop: SubOp -of_type: Word16 -compile_binop: MulOp -of_type: Word16 -compile_binop: DivOp -of_type: Word16 -compile_binop: ModOp -of_type: Word16 -compile_binop: PowOp -of_type: Word16 -compile_lit: (Word16Lit 2) -compile_binop: AndOp -of_type: Word16 -compile_binop: OrOp -of_type: Word16 -compile_binop: XorOp -of_type: Word16 -compile_binop: ShiftLOp -of_type: Word16 -compile_binop: ShiftROp -of_type: Word16 -compile_binop: RotLOp -of_type: Word16 -compile_binop: RotROp -of_type: Word16 -compile_lit: (Word8Lit 67) -compile_lit: (Word8Lit 7) -compile_lit: (Word8Lit 34) -compile_unop: NegOp -compile_lit: (Word8Lit 15) -compile_lit: (Word8Lit 200) -compile_unop: NegOp -compile_binop: AddOp -of_type: Word8 -compile_binop: SubOp -of_type: Word8 -compile_binop: MulOp -of_type: Word8 -compile_binop: DivOp -of_type: Word8 -compile_binop: ModOp -of_type: Word8 -compile_binop: PowOp -of_type: Word8 -compile_lit: (Word8Lit 2) -compile_binop: AndOp -of_type: Word8 -compile_binop: OrOp -of_type: Word8 -compile_binop: XorOp -of_type: Word8 -compile_binop: ShiftLOp -of_type: Word8 -compile_binop: ShiftROp -of_type: Word8 -compile_binop: RotLOp -of_type: Word8 -compile_binop: RotROp -of_type: Word8 diff --git a/test/run/text-iter.as b/test/run/text-iter.as new file mode 100644 index 00000000000..36f987b9392 --- /dev/null +++ b/test/run/text-iter.as @@ -0,0 +1,72 @@ +let s = "hello world!\n"; + +print "via `print`:\n"; +print s; +print "\n"; + +print "via iteration and `printChar`: #1\n"; +for (a in s.chars()) { + printChar a; +}; +print "\n"; + +print "via iteration and `printChar`: #2\n"; +var x = 0; +for (a in s.chars()) { + x += 1; + printInt x; + print ":"; + printChar '\''; + printChar a; + printChar '\''; + print " "; +}; +print "\n"; + +let russian = "Приветствую, мир!\n"; +assert(russian.len() == 18); + +print "via iteration and `printChar` (Unicode): #3\n"; +x := 0; +for (a in russian.chars()) { + x += 1; + printInt x; + print ":"; + printChar '\''; + printChar a; + printChar '\''; + print " "; +}; +print "\n"; +assert(x == 18); + +let emojis = "🙈🎸😋"; +assert(emojis.len() == 3); + +print "via iteration and `printChar` (Unicode): #4\n"; +x := 0; +for (a in emojis.chars()) { + x += 1; + printInt x; + print ":"; + printChar '\''; + printChar a; + printChar '\''; + print " "; +}; +print "\n"; +assert(x == 3); + +{ + let (len, c) = decodeUTF8 russian; + print russian; print "\n"; + printInt (word32ToInt len); print "\n"; + printChar c; print "\n"; +}; + +{ + let (len, c) = decodeUTF8 emojis; + assert ((len == (4 : Word32)) and (c == '\u{1f648}')); + printInt (word32ToInt len); print "\n"; + printChar c; print "\n"; +}; diff --git a/test/run/text-pats.as b/test/run/text-pats.as index a030910a043..5a5a9f551ef 100644 --- a/test/run/text-pats.as +++ b/test/run/text-pats.as @@ -3,4 +3,11 @@ switch "foo" { case "" assert false; case "foo" assert true; case _ assert false; +}; + +switch (?"foo") { + case (?"bar") assert false; + case (?"") assert false; + case (?"foo") assert true; + case _ assert false; } diff --git a/test/run/type-equivalence.as b/test/run/type-equivalence.as index b3256842fe9..0610b069f84 100644 --- a/test/run/type-equivalence.as +++ b/test/run/type-equivalence.as @@ -224,3 +224,5 @@ func f2(x : A2) : A2 = x : B2; func g1(x : A1) : A1 = x : C1; func g2(x : A2) : A2 = x : C2; }; + +() diff --git a/test/run/type-inclusion.as b/test/run/type-inclusion.as index 44b8e818c8f..14217da15eb 100644 --- a/test/run/type-inclusion.as +++ b/test/run/type-inclusion.as @@ -237,3 +237,5 @@ func f2(x : A2) : B2 = x; func g1(x : A1) : C1 = x; func g2(x : A2) : C2 = x; }; + +() diff --git a/test/run/word-rotations.as b/test/run/word-rotations.as new file mode 100644 index 00000000000..1f2d5d5c90c --- /dev/null +++ b/test/run/word-rotations.as @@ -0,0 +1,21 @@ +assert ((0x5bafecbd : Word32) <>> (4 : Word32) == (0xd5bafecb : Word32)); +assert ((0x5bafecbd : Word32) <>> (36 : Word32) == (0xd5bafecb : Word32)); + +assert ((0x5bbd : Word16) <>> (4 : Word16) == (0xd5bb : Word16)); +assert ((0x5bbd : Word16) <>> (20 : Word16) == (0xd5bb : Word16)); + + +assert ((0x56 : Word8) <>> (3 : Word8) == (0xca : Word8)); // 01010110 -> 11001010 +assert ((0x56 : Word8) <>> (11 : Word8) == (0xca : Word8)); +assert ((0x56 : Word8) <>> (19 : Word8) == (0xca : Word8)); + + +assert ((0x5bafecbd : Word32) <<> (4 : Word32) == (0xbafecbd5 : Word32)); +assert ((0x5bafecbd : Word32) <<> (36 : Word32) == (0xbafecbd5 : Word32)); + +assert ((0x5bbd : Word16) <<> (4 : Word16) == (0xbbd5 : Word16)); +assert ((0x5bbd : Word16) <<> (20 : Word16) == (0xbbd5 : Word16)); + +assert ((0x56 : Word8) <<> (3 : Word8) == (0xb2 : Word8)); // 01010110 -> 10110010 +assert ((0x56 : Word8) <<> (11 : Word8) == (0xb2 : Word8)); +assert ((0x56 : Word8) <<> (19 : Word8) == (0xb2 : Word8)); diff --git a/test/run/words.as b/test/run/words.as index e2a2132b80b..479df6a7f2a 100644 --- a/test/run/words.as +++ b/test/run/words.as @@ -1,3 +1,73 @@ +// CHECK: func $start + +func printBit(a : Bool) { print(if a "set" else "clear"); print "\n" }; + + +func checkpointAlpha() {}; +func checkpointBravo() {}; +func checkpointCharlie() {}; +func checkpointDelta() {}; +func checkpointEcho() {}; +func checkpointFoxtrot() {}; +func checkpointGolf() {}; +func checkpointHotel() {}; +func checkpointIndia() {}; +func checkpointJuliett() {}; + +// Word64 operations +{ + func printW64ln(w : Word64) { printInt(word64ToNat w); print " "; printInt(word64ToInt w); print "\n" }; + + let a : Word64 = 4567; + let b : Word64 = 7; + let c : Word64 = 8912765; + let d : Word64 = -15; + let e : Word64 = 20000; + +// CHECK: get_local $c +// CHECK-NOT: call $box_i64 +// CHECK: call $printW64ln + printW64ln(+c); + printW64ln(-c); + printW64ln(^c); + printW64ln(a + c); + printW64ln(c - a); + +// CHECK: call $checkpointAlpha + checkpointAlpha(); +// This is a native Wasm i64 multiplication, there should be no shift involved! +// CHECK-NOT: i64.shr_u +// CHECK: call $printW64ln + printW64ln(a * b); + + printW64ln(a / b); + printW64ln(c % a); + printW64ln(a ** 2); + + printW64ln(a & c); + printW64ln(a | c); + printW64ln(a ^ c); + printW64ln(a << b); + printW64ln(a >> b); + printW64ln(shrsWord64(d, 3)); + printW64ln(shrsWord64(-5225319197819536385, 4)); // 0b1011011101111011111011111101111111011111111011111111101111111111L == -5225319197819536385L --> -326582449863721025L + printW64ln(c <<> b); + printW64ln(c <>> b); + printW64ln(popcntWord64 d); // -15 = 0xfffffffffffffff1 = 0b1111_..._1111_1111_0001 (population = 61) + printW64ln(clzWord64 e); // 20000 = 0x0000000000004e20 (leading zeros = 49) + printW64ln(ctzWord64 e); // 20000 = 0x0000000000004e20 (trailing zeros = 5) + printBit(btstWord64(e, 5 : Word64)); // 20000 = 0x0000000000004e20 (result = true) + printBit(btstWord64(e, 63 : Word64)); // 20000 = 0x0000000000004e20 (result = false) + printBit(btstWord64(e, 69 : Word64)); // 20000 = 0x0000000000004e20 (mod 64, result = true) + + assert (3 : Word64 ** (4 : Word64) == (81 : Word64)); + assert (3 : Word64 ** (7 : Word64) == (2187 : Word64)); + assert (3 : Word64 ** (14 : Word64) == (4782969 : Word64)); + assert (3 : Word64 ** (20 : Word64) == (3486784401 : Word64)); +}; + + + // Word32 operations { func printW32ln(w : Word32) { printInt(word32ToNat w); print " "; printInt(word32ToInt w); print "\n" }; @@ -8,11 +78,22 @@ let d : Word32 = -15; let e : Word32 = 20000; - +// CHECK: call $checkpointBravo + checkpointBravo(); +// CHECK: get_local $c +// CHECK-NOT: call $box_i32 +// CHECK: call $printW32ln printW32ln(+c); printW32ln(-c); + printW32ln(^c); printW32ln(a + c); printW32ln(c - a); + +// CHECK: call $checkpointCharlie + checkpointCharlie(); +// This is a native Wasm i32 multiplication, there should be no shift involved! +// CHECK-NOT: i32.shr_u +// CHECK: call $printW32ln printW32ln(a * b); printW32ln(a / b); printW32ln(c % a); @@ -23,12 +104,21 @@ printW32ln(a ^ c); printW32ln(a << b); printW32ln(a >> b); - // printW32ln(shrs d b); // TODO(Gabor) + printW32ln(shrsWord32(d, 3)); + printW32ln(shrsWord32(-1216614433, 4)); // 0b10110111011110111110111111011111l == -1216614433l --> -76038403 printW32ln(c <<> b); printW32ln(c <>> b); - // printW32ln(lognot d); // TODO(Gabor) - // printW32ln(clz c); // TODO(Gabor) - // printW32ln(ctz e); // TODO(Gabor) + printW32ln(popcntWord32 d); // -15 = 0xfffffff1 = 0b1111_1111_1111_1111_1111_1111_1111_0001 (population = 29) + printW32ln(clzWord32 e); // 20000 = 0x00004e20 (leading zeros = 17) + printW32ln(ctzWord32 e); // 20000 = 0x00004e20 (trailing zeros = 5) + printBit(btstWord32(e, 5 : Word32)); // 20000 = 0x00004e20 (result = true) + printBit(btstWord32(e, 31 : Word32)); // 20000 = 0x00004e20 (result = false) + printBit(btstWord32(e, 37 : Word32)); // 20000 = 0x00004e20 (mod 32, result = true) + + assert (3 : Word32 ** (4 : Word32) == (81 : Word32)); + assert (3 : Word32 ** (7 : Word32) == (2187 : Word32)); + assert (3 : Word32 ** (14 : Word32) == (4782969 : Word32)); + assert (3 : Word32 ** (20 : Word32) == (3486784401 : Word32)); }; // Word16 operations @@ -44,8 +134,19 @@ printW16ln(+c); printW16ln(-c); + printW16ln(^c); printW16ln(a + c); printW16ln(c - a); + +// CHECK: call $checkpointDelta + checkpointDelta(); +// CHECK: get_local $a +// This is not a native Wasm i32 multiplication, we need to shift one of the args left by 16 bits! +// CHECK-NEXT: get_local $b +// CHECK-NEXT: i32.const 16 +// CHECK-NEXT: i32.shr_u +// CHECK-NEXT: i32.mul +// CHECK-NEXT: call $printW16ln printW16ln(a * b); printW16ln(a / b); printW16ln(c % a); @@ -55,13 +156,48 @@ printW16ln(a | c); printW16ln(a ^ c); printW16ln(a << b); + +// CHECK: call $checkpointEcho + checkpointEcho(); +// CHECK: get_local $b +// This is not a native Wasm i32 left shift, we need to shift the second arg left by 16 bits and clamp it to 4 bits! +// CHECK-NEXT: i32.const 16 +// CHECK-NEXT: i32.shr_u +// CHECK-NEXT: i32.const 15 +// CHECK-NEXT: i32.and +// CHECK-NEXT: i32.shr_u +// Then the result must be sanitised. +// CHECK-NEXT: i32.const -65536 +// CHECK-NEXT: i32.and +// CHECK-NEXT: call $printW16ln printW16ln(a >> b); - // printW16ln(shrs d b); // TODO(Gabor) + printW16ln(shrsWord16(d, 3 : Word16)); // -15 = 0xfff1 = 0b1111_1111_1111_0001 (shifted = 0b1111_1111_1111_1110 = -2) + +// CHECK: call $checkpointFoxtrot + checkpointFoxtrot(); +// CHECK: get_local $b +// CHECK-NEXT: call $rotl +// CHECK-NEXT: call $printW16ln printW16ln(c <<> b); + +// CHECK: call $checkpointGolf + checkpointGolf(); +// CHECK: get_local $b +// CHECK-NEXT: call $rotr +// CHECK-NEXT: call $printW16ln printW16ln(c <>> b); - // printW16ln(lognot d); // TODO(Gabor) - // printW16ln(clz c); // TODO(Gabor) - // printW16ln(ctz e); // TODO(Gabor) + printW16ln(popcntWord16 d); // -15 = 0xfff1 = 0b1111_1111_1111_0001 (population = 13) + printW16ln(clzWord16 e); // 20000 = 0x4e20 (leading zeros = 1) + printW16ln(ctzWord16 e); // 20000 = 0x4e20 (trailing zeros = 5) + printBit(btstWord16(e, 5 : Word16)); // 20000 = 0x4e20 (result = true) + printBit(btstWord16(e, 15 : Word16)); // 20000 = 0x4e20 (result = false) + printBit(btstWord16(e, 21 : Word16)); // 20000 = 0x4e20 (mod 16, result = true) + + + assert (3 : Word16 ** (0 : Word16) == (1 : Word16)); + assert (3 : Word16 ** (1 : Word16) == (3 : Word16)); + assert (3 : Word16 ** (4 : Word16) == (81 : Word16)); + assert (3 : Word16 ** (7 : Word16) == (2187 : Word16)); }; // Word8 operations @@ -77,8 +213,17 @@ printW8ln(+c); printW8ln(-c); + printW8ln(^c); printW8ln(a + c); printW8ln(c - a); +// CHECK: call $checkpointHotel + checkpointHotel(); +// CHECK: get_local $b +// This is not a native Wasm i32 multiplication, we need to shift one of the args left by 24 bits! +// CHECK-NEXT: i32.const 24 +// CHECK-NEXT: i32.shr_u +// CHECK-NEXT: i32.mul +// CHECK-NEXT: call $printW8ln printW8ln(a * b); printW8ln(a / b); printW8ln(c % a); @@ -88,11 +233,42 @@ printW8ln(a | c); printW8ln(a ^ c); printW8ln(a << b); + +// CHECK: call $checkpointIndia + checkpointIndia(); +// CHECK: get_local $b +// This is not a native Wasm i32 left shift, we need to shift the second arg left by 24 bits and clamp it to 3 bits! +// CHECK-NEXT: i32.const 24 +// CHECK-NEXT: i32.shr_u +// CHECK-NEXT: i32.const 7 +// CHECK-NEXT: i32.and +// CHECK-NEXT: i32.shr_u +// Then the result must be sanitised. +// CHECK-NEXT: i32.const -16777216 +// CHECK-NEXT: i32.and +// CHECK-NEXT: call $printW8ln printW8ln(a >> b); - // printW8ln(shrs d b); // TODO(Gabor) + printW8ln(shrsWord8(d, 3 : Word8)); // -15 = 0xf1 = 0b1111_0001 (shifted = 0b1111_1110 = -2) + +// CHECK: call $checkpointJuliett + checkpointJuliett(); +// CHECK: get_local $b +// CHECK-NEXT: call $rotl +// CHECK-NEXT: call $printW8ln printW8ln(c <<> b); +// CHECK: get_local $b +// CHECK-NEXT: call $rotr +// CHECK-NEXT: call $printW8ln printW8ln(c <>> b); - // printW8ln(lognot d); // TODO(Gabor) - // printW8ln(clz c); // TODO(Gabor) - // printW8ln(ctz e); // TODO(Gabor) + printW8ln(popcntWord8 d); // -15 = 0xf1 = 0b1111_0001 (population = 5) + printW8ln(clzWord8 e); // 200 = 0xC8 (leading zeros = 0) + printW8ln(ctzWord8 e); // 200 = 0xC8 (trailing zeros = 3) + printBit(btstWord8(e, 3 : Word8)); // 200 = 0xC8 (result = true) + printBit(btstWord8(e, 5 : Word8)); // 200 = 0xC8 (result = false) + printBit(btstWord8(e, 11 : Word8)); // 200 = 0xC8 (mod 8, result = true) + + assert (3 : Word8 ** (0 : Word8) == (1 : Word8)); + assert (3 : Word8 ** (3 : Word8) == (27 : Word8)); + assert (3 : Word8 ** (4 : Word8) == (81 : Word8)); + assert (3 : Word8 ** (5 : Word8) == (243 : Word8)); }; diff --git a/update-dvm.sh b/update-dvm.sh deleted file mode 100755 index 4e4aa39362d..00000000000 --- a/update-dvm.sh +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/bash - -# This is a small convenience script that ensures that `nix/dev` is up-to-date - -set -e - -if [ ! -e nix/dev ] -then git clone --recursive git@github.com:dfinity-lab/dev nix/dev -else git -C nix/dev fetch -fi -$(grep checkout Jenkinsfile |cut -d\' -f2) -git -C nix/dev submodule update --init --recursive -nix-env -i -f . -A dvm