├── .gitignore ├── LICENCE ├── Makefile ├── README.md ├── _tags ├── asl.ott ├── asl_utils.ml ├── asl_visitor.ml ├── asli.ml ├── asli.odocl ├── eval.ml ├── lexer.mll ├── lexersupport.ml ├── prelude.asl ├── primops.ml ├── tcheck.ml ├── testlexer.ml ├── utils.ml ├── value.ml └── visitor.ml /.gitignore: -------------------------------------------------------------------------------- 1 | asli 2 | *.byte 3 | *.native 4 | .*.swp 5 | .*.swo 6 | .*.un~ 7 | asl.tex 8 | asl_ast.ml 9 | asl_lexer.mll 10 | asl_parser.mly 11 | asl_parser_pp.ml 12 | _build 13 | asl_unquotiented.* 14 | asl_quotiented.* 15 | test.native 16 | *.aux 17 | *.dvi 18 | *.log 19 | *.out 20 | *.toc 21 | *.bbl 22 | *.blg 23 | *.cb 24 | *.cb2 25 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Copyright 2017-2019 Arm Limited 2 | SPDX-Licence-Identifier: BSD-3-Clause 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its contributors 15 | may be used to endorse or promote products derived from this software 16 | without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ################################################################ 2 | # ASL Makefile 3 | # 4 | # Copyright Arm Limited (c) 2017-2019 5 | # SPDX-Licence-Identifier: BSD-3-Clause 6 | ################################################################ 7 | 8 | .DEFAULT: all 9 | 10 | OTT := ott 11 | 12 | BUILDFLAGS += -use-ocamlfind 13 | BUILDFLAGS += -tag thread 14 | BUILDFLAGS += -tag debug 15 | BUILDFLAGS += -cflags -safe-string 16 | 17 | MENHIR_EXTRA = `opam config var ott:share`/menhir_library_extra.mly 18 | MENHIRFLAGS += --infer 19 | MENHIRFLAGS += --explain 20 | MENHIR := -menhir "menhir $(MENHIRFLAGS)" 21 | 22 | 23 | SRCS += asl_ast.ml 24 | SRCS += asl_parser.mly 25 | SRCS += asl_parser_pp.ml 26 | SRCS += asli.ml 27 | SRCS += lexersupport.ml 28 | SRCS += lexer.mll 29 | SRCS += tcheck.ml 30 | SRCS += asl_utils.ml 31 | SRCS += asl_visitor.ml 32 | SRCS += utils.ml 33 | SRCS += visitor.ml 34 | SRCS += primops.ml 35 | SRCS += value.ml 36 | SRCS += eval.ml 37 | 38 | all :: asli.native 39 | asli.native: $(SRCS) 40 | echo Execute the following: export DYLD_LIBRARY_PATH=`opam config var z3:lib` 41 | ocamlbuild $(BUILDFLAGS) $(MENHIR) $@ 42 | 43 | asli.byte: $(SRCS) 44 | echo Execute the following: export DYLD_LIBRARY_PATH=`opam config var z3:lib` 45 | ocamlbuild $(BUILDFLAGS) $(MENHIR) $@ 46 | 47 | doc :: asli.docdir/index.html 48 | asli.docdir/index.html: $(SRCS) 49 | ocamlbuild -use-ocamlfind $@ 50 | 51 | all :: asli 52 | asli: asli.native 53 | ln -f -s $^ asli 54 | 55 | clean :: 56 | $(RM) asli.byte asli.native asli 57 | $(RM) -r _build 58 | $(RM) asl.tex asl_ast.ml asl_parser.mly asl_lexer.mll asl_parser_pp.ml 59 | $(RM) -r asli.docdir 60 | ocamlbuild -clean 61 | 62 | all :: testlexer.native 63 | 64 | testlexer.native: testlexer.ml lexersupport.ml lexer.mll asl_parser.mly 65 | # Adding Z3 to the dynamic library path would not be necessary if we made 66 | # use of the Z3 package conditional on what target we were building 67 | echo Execute the following: export DYLD_LIBRARY_PATH=`opam config var z3:lib` 68 | ocamlbuild $(BUILDFLAGS) $(MENHIR) $@ 69 | 70 | 71 | # generate the ocaml AST type, ocamllex lexer, menhir parser, and ocaml pretty printers for the AST, all from the Ott soruce 72 | asl_ast.ml asl_lexer.mll asl_parser.mly asl_parser_pp.ml asl_ast.tex : asl.ott 73 | $(OTT) -aux_style_rules false -tex_wrap true -quotient_rules false -i asl.ott -o asl_parser.mly -o asl_lexer.mll -o asl_ast.ml -o asl.tex 74 | grep -v '^%%' $(MENHIR_EXTRA) >> asl_parser.mly 75 | 76 | # We need a separate rule to build LaTeX so that it is unquotiented 77 | # (despite the above specifying -quotient_rules false) 78 | asl_grammar.tex: asl.ott 79 | grep -v spice asl.ott | grep -v '__builtin' | grep -v '__function' | grep -v '__ExceptionTaken' > asl_clean.ott 80 | $(OTT) -tex_wrap false -quotient_rules false -generate_aux_rules false -aux_style_rules false -i asl_clean.ott -o $@ 81 | perl -p -i -e 's/{\\textsf{S}}/{}/' $@ 82 | 83 | clean :: 84 | $(RM) asl_grammar.tex asl_clean.ott 85 | 86 | all :: asl_quotiented.pdf 87 | pdf: asl_quotiented.pdf asl_unquotiented.pdf 88 | 89 | asl_quotiented.pdf: asl.ott Makefile 90 | $(OTT) -quotient_rules true -generate_aux_rules false -i asl.ott -o asl_quotiented.tex 91 | pdflatex asl_quotiented.tex 92 | 93 | asl_unquotiented.pdf: asl.ott Makefile 94 | $(OTT) -quotient_rules false -generate_aux_rules false -aux_style_rules false -i asl.ott -o asl_unquotiented.tex 95 | pdflatex asl_unquotiented.tex 96 | 97 | clean:: 98 | $(RM) *~ 99 | $(RM) asl_quotiented.{tex,pdf} 100 | $(RM) asl_unquotiented.{tex,pdf} 101 | $(RM) *.aux *.log *.bbl *.blg *.dvi *.out *.toc 102 | 103 | ################################################################ 104 | # End 105 | ################################################################ 106 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ASL Interpreter 2 | 3 | ## Introduction 4 | 5 | Example implementation of Arm's Architecture Specification Language (ASL). 6 | 7 | The ASL interpreter is a collection of resources to help you to 8 | understand and make use of Arm's architecture specifications. 9 | It consists of lexer, parser, typechecker and interpreter for the ASL language 10 | and an interactive interface for evaluating ASL statements and expressions. 11 | 12 | ## Requirements 13 | 14 | To build and run the ASL interpreter, you will need: 15 | 16 | * OCaml version 4.07 (other versions may work) 17 | * OPAM OCaml version 2.0.5 (other versions may work) 18 | * The following OPAM packages 19 | * ocaml - OCaml compiler 20 | * menhir - parser generator tool 21 | * ocamlfind - build tool for OCaml 22 | * ott.0.29 - tool for defining language grammars and semantics (this version or later required) 23 | * linenoise - OCaml line editing library 24 | * pprint - OCaml pretty-printing library 25 | * z3.4.7.1 - OCaml bindings for the Z3 SMT solver (exactly this version is required) 26 | * zarith - OCaml multiprecision arithmetic library 27 | 28 | ## License and contribution 29 | 30 | The software is provided under the [BSD-3-Clause licence](https://spdx.org/licenses/BSD-3-Clause.html). 31 | Contributions to this project are accepted under the same licence. 32 | 33 | This software includes code from one other open source projects 34 | 35 | * The [CIL project](https://people.eecs.berkeley.edu/~necula/cil/) 36 | defines a useful 37 | [visitor class](https://github.com/cil-project/cil/blob/936b04103eb573f320c6badf280e8bb17f6e7b26/src/cil.ml#L931) 38 | for traversing C ASTs. 39 | The file `visitor.ml` is a modified copy of this class that generalizes 40 | the type to work with an arbitrary AST. 41 | 42 | CIL is distributed under a [BSD-3-Clause licence](https://github.com/cil-project/cil/blob/develop/LICENSE). 43 | 44 | 45 | ## Building and development 46 | 47 | ### Directory structure 48 | 49 | This interpreter consists of a single directory organized as follows 50 | 51 | * Metadata, documentation, etc: 52 | * `LICENCE` - Software licence 53 | * `README.md` - This file 54 | * `asli.odocl` - Manifest (for documentation generation) 55 | * `Makefile` - build system file 56 | * `_tags` - OCaml build system configuration file 57 | * Source code consisting of 58 | * Lexer 59 | * `lexer.mll` - ASL lexer (ocamllex file) 60 | * `lexersupport.ml` - indentation-based parsing support 61 | * Grammar and Parser 62 | * `asl.ott` - used to generate the ASL parser and abstract syntax tree (OTT file) 63 | * `asl_visitor.ml` - code to traverse abstract syntax tree 64 | * `asl_utils.ml` - code to transform abstract syntax tree 65 | * Typechecker 66 | * `tcheck.ml` - typechecker 67 | * Interpreter 68 | * `primops.ml` - implementation of ASL builtin types and operations 69 | * `value.ml` - interpreter support code 70 | * `eval.ml` - evaluator for ASL language 71 | * ASL standard library 72 | * `prelude.asl` - builtin types and functions 73 | * Programs 74 | * `asli.ml` - interactive ASL tool 75 | * `testlexer.ml` - test program that converts ASL code to list of tokens 76 | * Misc 77 | * `utils.ml` - utility code 78 | * Code copied from other open source projects 79 | * `visitor.ml` 80 | 81 | 82 | ### Installing dependencies 83 | 84 | Platform specific instructions: 85 | ``` 86 | MacOS: brew install opam 87 | Ubuntu: sudo apt-get install opam 88 | ``` 89 | Platform independent instructions: 90 | 91 | ``` 92 | opam install ocaml 93 | opam install menhir 94 | opam install ocamlfind 95 | opam install ott 96 | opam install linenoise 97 | opam install pprint 98 | opam install z3.4.7.1 99 | opam install zarith 100 | 101 | eval `opam config env` 102 | ``` 103 | 104 | You also need to execute this command 105 | 106 | ``` 107 | MacOS: export DYLD_LIBRARY_PATH=`opam config var z3:lib` 108 | Linux: export LD_LIBRARY_PATH=`opam config var z3:lib` 109 | ``` 110 | 111 | 112 | ### Building 113 | 114 | To build the ASL lexer, the ASL interpreter and PDF files containing the ASL 115 | grammar, execute these commands. 116 | 117 | ``` 118 | make testlexer.native asli pdf doc 119 | ``` 120 | 121 | ### Using ASL lexer 122 | 123 | This displays a list of tokens in an ASL file including the indent 124 | and dedent tokens used to support indentation-based parsing. 125 | 126 | ``` 127 | $ ./testlexer.native prelude.asl 128 | ``` 129 | 130 | ### Using ASL interpreter 131 | 132 | This reads ASL files specified on the command line and 133 | provides an interactive environment for executing ASL 134 | statements and expressions. 135 | 136 | ``` 137 | $ ./asli 138 | _____ _ _ ___________________________________ 139 | /\ / ____|| | (_) ASL interpreter 140 | / \ | (___ | | _ Copyright Arm Limited (c) 2017-2019 141 | / /\ \ \___ \ | | | | 142 | / ____ \ ____) || |____ | | Version 0.0 alpha 143 | /_/ \_\|_____/ |______||_| ___________________________________ 144 | 145 | Type :? for help 146 | ASLi> 1+1 147 | 2 148 | ASLi> ZeroExtend('11', 32) 149 | '00000000000000000000000000000011' 150 | ASLi> bits(32) x = ZeroExtend('11', 32); 151 | ASLi> x 152 | '00000000000000000000000000000011' 153 | ASLi> :quit 154 | ``` 155 | 156 | Enjoy! 157 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: -traverse 2 | true: package(pprint) 3 | true: package(z3) 4 | true: package(zarith) 5 | true: package(linenoise) 6 | true: use_menhir 7 | -------------------------------------------------------------------------------- /asl_utils.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * ASL utility functions 3 | * 4 | * Copyright Arm Limited (c) 2017-2019 5 | * SPDX-Licence-Identifier: BSD-3-Clause 6 | ****************************************************************) 7 | 8 | (** ASL utility functions *) 9 | 10 | module PP = Asl_parser_pp 11 | module AST = Asl_ast 12 | module Visitor = Asl_visitor 13 | 14 | open AST 15 | open Visitor 16 | 17 | (****************************************************************) 18 | (** {2 Bindings and IdentSet} *) 19 | (****************************************************************) 20 | 21 | (** {2 Bindings: maps indexed by identifiers} *) 22 | module Bindings = Map.Make(AST.Id) 23 | 24 | (** add association list to bindings *) 25 | let add_bindings (bs: 'a Bindings.t) (xs: (ident * 'a) list): 'a Bindings.t = 26 | List.fold_left (fun a (k, v) -> Bindings.add k v a) bs xs 27 | 28 | (** create bindings from association list *) 29 | let mk_bindings (xs: (ident * 'a) list): 'a Bindings.t = 30 | add_bindings Bindings.empty xs 31 | 32 | (** print bindings *) 33 | let pp_bindings (pp: 'a -> string) (bs: 'a Bindings.t): string = 34 | String.concat ", " (List.map (fun (k, v) -> pprint_ident k ^"->"^ pp v) (Bindings.bindings bs)) 35 | 36 | 37 | (** {2 Sets of identifiers} *) 38 | module IdentSet = Set.Make(Id) 39 | 40 | (** merge a list of sets *) 41 | let unionSets (idss: IdentSet.t list): IdentSet.t = 42 | List.fold_left IdentSet.union IdentSet.empty idss 43 | 44 | (** add v to set of identifiers mapped to k *) 45 | let addToBindingSet (k: ident) (v: ident) (bs: IdentSet.t Bindings.t): IdentSet.t Bindings.t = 46 | Bindings.update k (fun old -> 47 | (match old with 48 | | None -> Some (IdentSet.singleton v) 49 | | Some vs -> Some (IdentSet.add v vs) 50 | ) 51 | ) bs 52 | 53 | (** convert identifier set to sorted list of identifiers 54 | 55 | The implementation is trivial and exists mostly to emphasize that the 56 | resulting list is sorted 57 | *) 58 | let to_sorted_list (s: IdentSet.t): ident list = 59 | IdentSet.elements s 60 | 61 | 62 | (****************************************************************) 63 | (** {2 Equivalence classes} *) 64 | (****************************************************************) 65 | 66 | (** Equivalence classes are represented by trees. 67 | 68 | The root of the tree is the canonical member of the class. 69 | Traversing the parent node takes you closer to the canonical member. 70 | The root is its own parent. 71 | *) 72 | type tree = { 73 | mutable parent : tree; 74 | data : ident; 75 | } 76 | 77 | (** Equivalence class support (to support unification, and similar) 78 | 79 | The implementation is based on 80 | {{:https://en.wikipedia.org/wiki/Disjoint-set_data_structure}Wikipedia: Union-Find}. 81 | I have not implemented all the optimizations they suggest 82 | because I expect sets to be quite small in practice. 83 | *) 84 | 85 | class equivalences = object (self) 86 | 87 | (* Mapping from elements to the set containing them *) 88 | val mutable forest : tree Bindings.t = Bindings.empty 89 | 90 | (* Find the root (canonical member of) the set. 91 | * Implements "path-splitting" optimisation that makes every node 92 | * point to its grandfather so each traversal reduces height of tree. 93 | *) 94 | method private find (x: tree): tree = 95 | let r = ref x in 96 | while !r.parent != !r do 97 | let next = !r.parent in 98 | !r.parent <- next.parent; 99 | r := next 100 | done; 101 | !r 102 | 103 | (* Find the root of the set containing 'x' - creating a new 104 | * set if not already known *) 105 | method private find_ident (x: ident): tree = 106 | let s = (match Bindings.find_opt x forest with 107 | | None -> 108 | let rec t = { parent = t; data = x; } in 109 | t 110 | | Some t -> 111 | self#find t 112 | ) in 113 | forest <- Bindings.add x s forest; 114 | s 115 | 116 | (* Find the canonical member of the set containing 'x' *) 117 | method canonicalize (x: ident): ident = 118 | let s = self#find_ident x in 119 | s.data 120 | 121 | (* Merge the sets containing 'x' and 'y' *) 122 | method merge (x: ident) (y: ident): unit = 123 | let x' = self#find_ident x in 124 | let y' = self#find_ident y in 125 | if x != y then y'.parent <- x' 126 | 127 | (* Optimization: short circuit every tree so that they all point directly at root *) 128 | method private normalize: unit = 129 | forest <- Bindings.map (self#find) forest 130 | 131 | (* Return mapping from identifiers to the canonical representation of their 132 | * equivalence class 133 | *) 134 | method mapping: ident Bindings.t = 135 | self#normalize; 136 | Bindings.map (fun t -> (self#find t).data) forest 137 | 138 | (* Construct equivalence classes for each canonical member of a class. 139 | * 140 | * The implementation of this could be made more efficient by adding 141 | * pointers to trees so that we can map each canonical member to a 142 | * tree containing all the nodes that point to it. 143 | * But this implementation just does a linear scan over all the members 144 | * of the forest. 145 | *) 146 | method classes: IdentSet.t Bindings.t = 147 | Bindings.fold (fun k v -> addToBindingSet v k) self#mapping Bindings.empty 148 | 149 | (* Print equivalence classes adding a prefix at the start of every line of 150 | * output. 151 | *) 152 | method pp (prefix: string): unit = 153 | Bindings.iter (fun v vs -> 154 | Printf.printf "%s%s -> {" prefix (pprint_ident v); 155 | IdentSet.iter (fun w -> Printf.printf " %s" (pprint_ident w)) vs; 156 | Printf.printf "}\n"; 157 | ) self#classes 158 | end 159 | 160 | 161 | (****************************************************************) 162 | (** {1 AST Transformation Utilities} *) 163 | (****************************************************************) 164 | 165 | (****************************************************************) 166 | (** {2 Calculating free variables of expressions and types} *) 167 | (****************************************************************) 168 | 169 | class freevarClass = object 170 | inherit nopAslVisitor 171 | 172 | val mutable fvs = IdentSet.empty 173 | method result = fvs 174 | method vvar x = 175 | fvs <- IdentSet.add x fvs; 176 | SkipChildren 177 | end 178 | 179 | let rec fv_expr (x: expr): IdentSet.t = 180 | let fv = new freevarClass in 181 | ignore (visit_expr (fv :> aslVisitor) x); 182 | fv#result 183 | 184 | let rec fv_type (x: ty): IdentSet.t = 185 | let fv = new freevarClass in 186 | ignore (visit_type (fv :> aslVisitor) x); 187 | fv#result 188 | 189 | let fv_args (atys: (ty * ident) list): IdentSet.t = 190 | unionSets (List.map (fun (ty, _) -> fv_type ty) atys) 191 | 192 | let fv_sformal (x: sformal): IdentSet.t = 193 | (match x with 194 | | Formal_In(ty,v) -> fv_type ty 195 | | Formal_InOut(ty,v) -> fv_type ty 196 | ) 197 | 198 | let fv_sformals (atys: sformal list): IdentSet.t = 199 | unionSets (List.map fv_sformal atys) 200 | 201 | 202 | (****************************************************************) 203 | (** {2 Substitutions} *) 204 | (****************************************************************) 205 | 206 | (** Performing variable substitutions in expressions and types 207 | 208 | Note that it does not replace type constructors, global constants 209 | or enumerations in patterns, array indexes and types so this is 210 | limited to replacing local variables. 211 | It also does not replace variables used as l-expressions though 212 | that it easily changed if we think it should. *) 213 | class substClass (s: expr Bindings.t) = object 214 | inherit nopAslVisitor 215 | method vexpr x = 216 | (match x with 217 | | Expr_Var v -> 218 | (match Bindings.find_opt v s with 219 | | Some r -> ChangeTo r 220 | | None -> DoChildren 221 | ) 222 | | _ -> DoChildren 223 | ) 224 | end 225 | 226 | let rec subst_expr (s: expr Bindings.t) (x: expr): expr = 227 | let subst = new substClass s in 228 | visit_expr subst x 229 | 230 | let rec subst_lexpr (s: expr Bindings.t) (x: lexpr): lexpr = 231 | let subst = new substClass s in 232 | visit_lexpr subst x 233 | 234 | let rec subst_slice (s: expr Bindings.t) (x: slice): slice = 235 | let subst = new substClass s in 236 | visit_slice subst x 237 | 238 | let rec subst_type (s: expr Bindings.t) (x: ty): ty = 239 | let subst = new substClass s in 240 | visit_type subst x 241 | 242 | 243 | (** More flexible substitution class - takes a function instead 244 | of a binding set. 245 | *) 246 | class substFunClass (replace: ident -> expr option) = object 247 | inherit nopAslVisitor 248 | method vexpr x = 249 | (match x with 250 | | Expr_Var v -> 251 | (match replace v with 252 | | Some r -> ChangeTo r 253 | | None -> DoChildren 254 | ) 255 | | _ -> DoChildren 256 | ) 257 | end 258 | 259 | (****************************************************************) 260 | (** {2 Expression transformation} *) 261 | (****************************************************************) 262 | 263 | (** Expression transformation class 264 | 265 | Applies replace function to any subexpression. 266 | (Especially useful for expressions in types) *) 267 | class replaceExprClass (replace: expr -> expr option) = object 268 | inherit nopAslVisitor 269 | method vexpr x = 270 | (match replace x with 271 | | Some r -> ChangeTo r 272 | | None -> SkipChildren 273 | ) 274 | end 275 | 276 | (****************************************************************) 277 | (** {2 Resugaring} *) 278 | (****************************************************************) 279 | 280 | (** Resugaring transform 281 | 282 | The typechecker desugars infix syntax to make it absolutely explicit 283 | what it means. This is good for tools but bad for humans. 284 | 285 | This transformation re-introduces the infix syntax - the intention 286 | being that you might use this in error messages. 287 | It also deletes type parameters - so this is (more or less) 288 | the reverse of typechecking. *) 289 | class resugarClass (ops: AST.binop Bindings.t) = object (self) 290 | inherit nopAslVisitor 291 | method vexpr x = 292 | (match x with 293 | | Expr_TApply(f, tys, args) -> 294 | let args' = List.map (visit_expr (self :> aslVisitor)) args in 295 | (match (Bindings.find_opt f ops, args') with 296 | | (Some op, [a; b]) -> ChangeTo (Expr_Binop(a, op, b)) 297 | (* | (Some op, [a]) -> ChangeTo (Expr_Unop(op, a)) *) 298 | | _ -> ChangeTo (Expr_TApply(f, [], args')) 299 | ) 300 | | _ -> 301 | DoChildren 302 | ) 303 | end 304 | 305 | let rec resugar_expr (ops: AST.binop Bindings.t) (x: expr): expr = 306 | let resugar = new resugarClass ops in 307 | visit_expr resugar x 308 | 309 | let rec resugar_type (ops: AST.binop Bindings.t) (x: AST.ty): AST.ty = 310 | let resugar = new resugarClass ops in 311 | visit_type resugar x 312 | 313 | (****************************************************************) 314 | (** {2 Pretty printing wrappers} *) 315 | (****************************************************************) 316 | 317 | let pp_type (x: ty): string = Utils.to_string (PP.pp_ty x) 318 | let pp_expr (x: expr): string = Utils.to_string (PP.pp_expr x) 319 | let pp_lexpr (x: lexpr): string = Utils.to_string (PP.pp_lexpr x) 320 | let pp_stmt (x: stmt): string = Utils.to_string (PP.pp_stmt x) 321 | 322 | 323 | (****************************************************************) 324 | (** {2 Misc} *) 325 | (****************************************************************) 326 | 327 | (** Length of bitstring or mask literal. 328 | 329 | ASL bit and mask literals allow spaces to be included - these 330 | do not count towards the length of the literal. 331 | *) 332 | let masklength (x: string): int = 333 | let r = ref 0 in 334 | String.iter (function ' ' -> () | _ -> r := !r + 1) x; 335 | !r 336 | 337 | (**************************************************************** 338 | * End 339 | ****************************************************************) 340 | -------------------------------------------------------------------------------- /asl_visitor.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * ASL visitor class 3 | * 4 | * Copyright Arm Limited (c) 2017-2019 5 | * SPDX-Licence-Identifier: BSD-3-Clause 6 | * 7 | * This code follows the pattern used in the cilVisitor class in 8 | * George Necula's excellent CIL (https://people.eecs.berkeley.edu/~necula/cil/) 9 | * and makes use of the generic Visitor module that is copied from CIL. 10 | ****************************************************************) 11 | 12 | (** ASL visitor class *) 13 | 14 | open Asl_ast 15 | open Visitor 16 | 17 | (****************************************************************) 18 | (** {2 ASL visitor class} *) 19 | (****************************************************************) 20 | 21 | (** For each datatype in the ASL AST, a visitor defines what actions 22 | it wants to perform on values of that type. 23 | *) 24 | 25 | class type aslVisitor = object 26 | 27 | method vvar : ident -> ident visitAction 28 | method ve_elsif : e_elsif -> e_elsif visitAction 29 | method vslice : slice -> slice visitAction 30 | method vpattern : pattern -> pattern visitAction 31 | method vexpr : expr -> expr visitAction 32 | method vtype : ty -> ty visitAction 33 | method vlvar : ident -> ident visitAction 34 | method vlexpr : lexpr -> lexpr visitAction 35 | method vstmt : stmt -> stmt visitAction 36 | method vs_elsif : s_elsif -> s_elsif visitAction 37 | method valt : alt -> alt visitAction 38 | method vcatcher : catcher -> catcher visitAction 39 | method vmapfield : mapfield -> mapfield visitAction 40 | method vsformal : sformal -> sformal visitAction 41 | method vdpattern : decode_pattern -> decode_pattern visitAction 42 | method vencoding : encoding -> encoding visitAction 43 | method vdcase : decode_case -> decode_case visitAction 44 | method vdalt : decode_alt -> decode_alt visitAction 45 | method vdbody : decode_body -> decode_body visitAction 46 | method vdecl : declaration -> declaration visitAction 47 | 48 | end 49 | 50 | 51 | (****************************************************************) 52 | (** {2 ASL visitor functions} *) 53 | (****************************************************************) 54 | 55 | (** The following set of recursive functions are the ASL specific 56 | part of the visitor class. 57 | For each data constructor of each datatype, they invoke visitors 58 | on each field of the data constructor and then reconstruct 59 | the corresponding data constructor. 60 | 61 | These functions implement the space-saving optimisation of 62 | only reconstructing the constructor if the sub-values are 63 | different. 64 | *) 65 | 66 | let rec visit_exprs (vis: aslVisitor) (xs: expr list): expr list = 67 | mapNoCopy (visit_expr vis) xs 68 | 69 | and visit_var (vis: aslVisitor) (x: ident): ident = 70 | let aux (vis: aslVisitor) (x: ident): ident = 71 | x 72 | in 73 | doVisit vis (vis#vvar x) aux x 74 | 75 | and visit_lvar (vis: aslVisitor) (x: ident): ident = 76 | let aux (vis: aslVisitor) (x: ident): ident = 77 | x 78 | in 79 | doVisit vis (vis#vlvar x) aux x 80 | 81 | and visit_e_elsif (vis: aslVisitor) (x: e_elsif): e_elsif = 82 | let aux (vis: aslVisitor) (x: e_elsif): e_elsif = 83 | (match x with 84 | | E_Elsif_Cond(c, e) -> 85 | let c' = visit_expr vis c in 86 | let e' = visit_expr vis e in 87 | if c == c' && e == e' then x else E_Elsif_Cond(c', e') 88 | ) 89 | in 90 | doVisit vis (vis#ve_elsif x) aux x 91 | 92 | and visit_slice (vis: aslVisitor) (x: slice): slice = 93 | let aux (vis: aslVisitor) (x: slice): slice = 94 | (match x with 95 | | Slice_Single(e) -> 96 | let e' = visit_expr vis e in 97 | if e == e' then x else Slice_Single e' 98 | | Slice_HiLo(hi, lo) -> 99 | let hi' = visit_expr vis hi in 100 | let lo' = visit_expr vis lo in 101 | if hi == hi' && lo == lo' then x else Slice_HiLo(hi', lo') 102 | | Slice_LoWd(lo, wd) -> 103 | let lo' = visit_expr vis lo in 104 | let wd' = visit_expr vis wd in 105 | if lo == lo' && wd == wd' then x else Slice_LoWd(lo', wd') 106 | ) 107 | in 108 | doVisit vis (vis#vslice x) aux x 109 | 110 | and visit_patterns (vis: aslVisitor) (xs: pattern list): pattern list = 111 | mapNoCopy (visit_pattern vis) xs 112 | 113 | and visit_pattern (vis: aslVisitor) (x: pattern): pattern = 114 | let aux (vis: aslVisitor) (x: pattern): pattern = 115 | ( match x with 116 | | Pat_LitInt(l) -> x 117 | | Pat_LitHex(l) -> x 118 | | Pat_LitBits(l) -> x 119 | | Pat_LitMask(l) -> x 120 | | Pat_Const(l) -> x 121 | | Pat_Wildcard -> x 122 | | Pat_Tuple(ps) -> 123 | let ps' = visit_patterns vis ps in 124 | if ps == ps' then x else Pat_Tuple ps' 125 | | Pat_Set(ps) -> 126 | let ps' = visit_patterns vis ps in 127 | if ps == ps' then x else Pat_Set ps' 128 | | Pat_Single(e) -> 129 | let e' = visit_expr vis e in 130 | if e == e' then x else Pat_Single(e') 131 | | Pat_Range(lo, hi) -> 132 | let lo' = visit_expr vis lo in 133 | let hi' = visit_expr vis hi in 134 | if lo == lo' && hi == hi' then x else Pat_Range(lo', hi') 135 | ) 136 | in 137 | doVisit vis (vis#vpattern x) aux x 138 | 139 | and visit_expr (vis: aslVisitor) (x: expr): expr = 140 | let aux (vis: aslVisitor) (x: expr): expr = 141 | (match x with 142 | | Expr_If(c, t, els, e) -> 143 | let c' = visit_expr vis c in 144 | let t' = visit_expr vis t in 145 | let els' = mapNoCopy (visit_e_elsif vis) els in 146 | let e' = visit_expr vis e in 147 | if c == c' && t == t' && els == els' && e == e' then x else Expr_If(c', t', els', e') 148 | | Expr_Binop(a, op, b) -> 149 | let a' = visit_expr vis a in 150 | let b' = visit_expr vis b in 151 | if a == a' && b == b' then x else Expr_Binop(a', op, b') 152 | | Expr_Field(e, f) -> 153 | let e' = visit_expr vis e in 154 | if e == e' then x else Expr_Field(e', f) 155 | | Expr_Fields(e, fs) -> 156 | let e' = visit_expr vis e in 157 | if e == e' then x else Expr_Fields(e', fs) 158 | | Expr_Slices(e, ss) -> 159 | let e' = visit_expr vis e in 160 | let ss' = mapNoCopy (visit_slice vis) ss in 161 | if e == e' && ss == ss' then x else Expr_Slices(e', ss') 162 | | Expr_In(e, p) -> 163 | let e' = visit_expr vis e in 164 | let p' = visit_pattern vis p in 165 | if e == e' && p == p' then x else Expr_In(e', p') 166 | | Expr_Var(v) -> 167 | let v' = visit_var vis v in 168 | if v == v' then x else Expr_Var(v') 169 | | Expr_Parens(e) -> 170 | let e' = visit_expr vis e in 171 | if e == e' then x else Expr_Parens e' 172 | | Expr_TApply(f, tes, es) -> 173 | let tes' = visit_exprs vis tes in 174 | let es' = visit_exprs vis es in 175 | if tes == tes' && es == es' then x else Expr_TApply(f, tes', es') 176 | | Expr_Tuple(es) -> 177 | let es' = visit_exprs vis es in 178 | if es == es' then x else Expr_Tuple es' 179 | | Expr_Unop(op, e) -> 180 | let e' = visit_expr vis e in 181 | if e == e' then x else Expr_Unop(op, e') 182 | | Expr_Unknown(t) -> 183 | let t' = visit_type vis t in 184 | if t == t' then x else Expr_Unknown t' 185 | | Expr_ImpDef(t, os) -> 186 | let t' = visit_type vis t in 187 | if t == t' then x else Expr_ImpDef(t', os) 188 | | Expr_Array(a, e) -> 189 | let a' = visit_expr vis a in 190 | let e' = visit_expr vis e in 191 | if a == a' && e == e' then x else Expr_Array(a', e') 192 | | Expr_LitInt _ -> x 193 | | Expr_LitHex _ -> x 194 | | Expr_LitReal _ -> x 195 | | Expr_LitBits _ -> x 196 | | Expr_LitMask _ -> x 197 | | Expr_LitString _ -> x 198 | ) 199 | in 200 | doVisit vis (vis#vexpr x) aux x 201 | 202 | 203 | and visit_types (vis: aslVisitor) (xs: ty list): ty list = 204 | mapNoCopy (visit_type vis) xs 205 | 206 | and visit_type (vis: aslVisitor) (x: ty): ty = 207 | let aux (vis: aslVisitor) (x: ty): ty = 208 | ( match x with 209 | | Type_Constructor(tc) -> x 210 | | Type_Bits(n) -> 211 | let n' = visit_expr vis n in 212 | if n == n' then x else Type_Bits(n') 213 | | Type_App(tc, es) -> 214 | let es' = visit_exprs vis es in 215 | if es == es' then x else Type_App(tc, es') 216 | | Type_OfExpr(e) -> 217 | let e' = visit_expr vis e in 218 | if e == e' then x else Type_OfExpr(e') 219 | | Type_Register(wd, fs) -> 220 | let fs' = mapNoCopy (fun ((ss, f) as r) -> 221 | let ss' = mapNoCopy (visit_slice vis) ss in 222 | if ss == ss' then r else (ss', f) 223 | ) fs in 224 | if fs == fs' then x else Type_Register(wd, fs') 225 | | Type_Array(Index_Enum(tc), ety) -> 226 | let ety' = visit_type vis ety in 227 | if ety == ety' then x else Type_Array(Index_Enum(tc), ety') 228 | | Type_Array(Index_Range(lo, hi), ety) -> 229 | let lo' = visit_expr vis lo in 230 | let hi' = visit_expr vis hi in 231 | let ety' = visit_type vis ety in 232 | if lo == lo' && hi == hi' && ety == ety' then x else Type_Array(Index_Range(lo',hi'),ety') 233 | | Type_Tuple(tys) -> 234 | let tys' = visit_types vis tys in 235 | if tys == tys' then x else Type_Tuple(tys') 236 | ) 237 | in 238 | doVisit vis (vis#vtype x) aux x 239 | 240 | let rec visit_lexprs (vis: aslVisitor) (xs: lexpr list): lexpr list = 241 | mapNoCopy (visit_lexpr vis) xs 242 | 243 | and visit_lexpr (vis: aslVisitor) (x: lexpr): lexpr = 244 | let aux (vis: aslVisitor) (x: lexpr): lexpr = 245 | ( match x with 246 | | LExpr_Wildcard -> x 247 | | LExpr_Var(v) -> 248 | let v' = visit_lvar vis v in 249 | if v == v' then x else LExpr_Var(v') 250 | | LExpr_Field(e, f) -> 251 | let e' = visit_lexpr vis e in 252 | if e == e' then x else LExpr_Field(e', f) 253 | | LExpr_Fields(e, fs) -> 254 | let e' = visit_lexpr vis e in 255 | if e == e' then x else LExpr_Fields(e', fs) 256 | | LExpr_Slices(e, ss) -> 257 | let e' = visit_lexpr vis e in 258 | let ss' = mapNoCopy (visit_slice vis) ss in 259 | if e == e' && ss == ss' then x else LExpr_Slices(e', ss') 260 | | LExpr_BitTuple(es) -> 261 | let es' = mapNoCopy (visit_lexpr vis) es in 262 | if es == es' then x else LExpr_BitTuple es' 263 | | LExpr_Tuple(es) -> 264 | let es' = mapNoCopy (visit_lexpr vis) es in 265 | if es == es' then x else LExpr_Tuple es' 266 | | LExpr_Array(a, e) -> 267 | let a' = visit_lexpr vis a in 268 | let e' = visit_expr vis e in 269 | if a == a' && e == e' then x else LExpr_Array(a', e') 270 | | LExpr_Write(f, tes, es) -> 271 | let f' = visit_var vis f in 272 | let tes' = visit_exprs vis tes in 273 | let es' = visit_exprs vis es in 274 | if f == f' && tes == tes' && es == es' then x else LExpr_Write(f, tes', es') 275 | | LExpr_ReadWrite(f, g, tes, es) -> 276 | let f' = visit_var vis f in 277 | let g' = visit_var vis g in 278 | let tes' = visit_exprs vis tes in 279 | let es' = visit_exprs vis es in 280 | if f == f' && g == g' && tes == tes' && es == es' then x else LExpr_ReadWrite(f, g, tes', es') 281 | ) 282 | in 283 | doVisit vis (vis#vlexpr x) aux x 284 | 285 | (* todo: should probably make this more like cil visitor and allow 286 | * visit_stmt to generate a list of statements and provide a mechanism to emit 287 | * statements to be inserted before/after the statement being transformed 288 | *) 289 | let rec visit_stmts (vis: aslVisitor) (xs: stmt list): stmt list = 290 | mapNoCopy (visit_stmt vis) xs 291 | 292 | and visit_stmt (vis: aslVisitor) (x: stmt): stmt = 293 | let aux (vis: aslVisitor) (x: stmt): stmt = 294 | (match x with 295 | | Stmt_VarDeclsNoInit (ty, vs, loc) -> 296 | let ty' = visit_type vis ty in 297 | let vs' = mapNoCopy (visit_lvar vis) vs in 298 | if ty == ty' && vs == vs' then x else Stmt_VarDeclsNoInit (ty', vs', loc) 299 | | Stmt_VarDecl (ty, v, i, loc) -> 300 | let ty' = visit_type vis ty in 301 | let v' = visit_lvar vis v in 302 | let i' = visit_expr vis i in 303 | if ty == ty' && v == v' && i == i' then x else Stmt_VarDecl (ty', v', i', loc) 304 | | Stmt_ConstDecl (ty, v, i, loc) -> 305 | let ty' = visit_type vis ty in 306 | let v' = visit_lvar vis v in 307 | let i' = visit_expr vis i in 308 | if ty == ty' && v == v' && i == i' then x else Stmt_ConstDecl (ty', v', i', loc) 309 | | Stmt_Assign (l, r, loc) -> 310 | let l' = visit_lexpr vis l in 311 | let r' = visit_expr vis r in 312 | if l == l' && r == r' then x else Stmt_Assign (l', r', loc) 313 | | Stmt_TCall (f, tes, args, loc) -> 314 | let f' = visit_var vis f in 315 | let tes' = visit_exprs vis tes in 316 | let args' = visit_exprs vis args in 317 | if f == f' && tes == tes' && args == args' then x else Stmt_TCall (f', tes', args', loc) 318 | | Stmt_FunReturn (e, loc) -> 319 | let e' = visit_expr vis e in 320 | if e == e' then x else Stmt_FunReturn (e', loc) 321 | | Stmt_ProcReturn (loc) -> x 322 | | Stmt_Assert (e, loc) -> 323 | let e' = visit_expr vis e in 324 | if e == e' then x else Stmt_Assert (e', loc) 325 | | Stmt_Unpred (loc) -> x 326 | | Stmt_ConstrainedUnpred(loc) -> x 327 | | Stmt_ImpDef (v, loc) -> 328 | let v' = visit_var vis v in 329 | if v == v' then x else Stmt_ImpDef (v', loc) 330 | | Stmt_Undefined (loc) -> x 331 | | Stmt_ExceptionTaken (loc) -> x 332 | | Stmt_Dep_Unpred (loc) -> x 333 | | Stmt_Dep_ImpDef (s, loc) -> x 334 | | Stmt_Dep_Undefined (loc) -> x 335 | | Stmt_See (e, loc) -> 336 | let e' = visit_expr vis e in 337 | if e == e' then x else Stmt_See (e', loc) 338 | | Stmt_Throw (v, loc) -> 339 | let v' = visit_var vis v in 340 | if v == v' then x else Stmt_Throw (v', loc) 341 | | Stmt_If (c, t, els, e, loc) -> 342 | let c' = visit_expr vis c in 343 | let t' = visit_stmts vis t in 344 | let els' = mapNoCopy (visit_s_elsif vis) els in 345 | let e' = visit_stmts vis e in 346 | if c == c' && t == t' && els == els' && e == e' then x else Stmt_If (c', t', els', e', loc) 347 | | Stmt_Case (e, alts, ob, loc) -> 348 | let e' = visit_expr vis e in 349 | let alts' = mapNoCopy (visit_alt vis) alts in 350 | let ob' = mapOptionNoCopy (visit_stmts vis) ob in 351 | if e == e' && alts == alts' && ob == ob' then x else Stmt_Case (e', alts', ob', loc) 352 | | Stmt_For (v, f, dir, t, b, loc) -> 353 | let v' = visit_lvar vis v in 354 | let f' = visit_expr vis f in 355 | let t' = visit_expr vis t in 356 | let b' = visit_stmts vis b in 357 | if v == v' && f == f' && t == t' && b == b' then x else Stmt_For (v', f', dir, t', b', loc) 358 | | Stmt_While (c, b, loc) -> 359 | let c' = visit_expr vis c in 360 | let b' = visit_stmts vis b in 361 | if c == c' && b == b' then x else Stmt_While (c', b', loc) 362 | | Stmt_Repeat (b, c, loc) -> 363 | let b' = visit_stmts vis b in 364 | let c' = visit_expr vis c in 365 | if b == b' && c == c' then x else Stmt_Repeat (b', c', loc) 366 | | Stmt_Try (b, v, cs, ob, loc) -> 367 | let b' = visit_stmts vis b in 368 | let v' = visit_lvar vis v in 369 | let cs' = mapNoCopy (visit_catcher vis) cs in 370 | let ob' = mapOptionNoCopy (visit_stmts vis) ob in 371 | if b == b' && v == v' && cs == cs' && ob == ob' then x else Stmt_Try (b', v', cs', ob', loc) 372 | 373 | ) 374 | in 375 | doVisit vis (vis#vstmt x) aux x 376 | 377 | and visit_s_elsif (vis: aslVisitor) (x: s_elsif): s_elsif = 378 | let aux (vis: aslVisitor) (x: s_elsif): s_elsif = 379 | (match x with 380 | | S_Elsif_Cond(c, b) -> 381 | let c' = visit_expr vis c in 382 | let b' = visit_stmts vis b in 383 | if c == c' && b == b' then x else S_Elsif_Cond(c', b') 384 | ) 385 | in 386 | doVisit vis (vis#vs_elsif x) aux x 387 | 388 | and visit_alt (vis: aslVisitor) (x: alt): alt = 389 | let aux (vis: aslVisitor) (x: alt): alt = 390 | (match x with 391 | | Alt_Alt(ps, oc, b) -> 392 | let ps' = visit_patterns vis ps in 393 | let oc' = mapOptionNoCopy (visit_expr vis) oc in 394 | let b' = visit_stmts vis b in 395 | if ps == ps' && oc == oc' && b == b' then x else Alt_Alt(ps', oc', b') 396 | ) 397 | in 398 | doVisit vis (vis#valt x) aux x 399 | 400 | and visit_catcher (vis: aslVisitor) (x: catcher): catcher = 401 | let aux (vis: aslVisitor) (x: catcher): catcher = 402 | (match x with 403 | | Catcher_Guarded(c, b) -> 404 | let c' = visit_expr vis c in 405 | let b' = visit_stmts vis b in 406 | if c == c' && b == b' then x else Catcher_Guarded(c', b') 407 | ) 408 | in 409 | doVisit vis (vis#vcatcher x) aux x 410 | 411 | 412 | let visit_mapfield (vis: aslVisitor) (x: mapfield): mapfield = 413 | let aux (vis: aslVisitor) (x: mapfield): mapfield = 414 | (match x with 415 | | MapField_Field (v, p) -> 416 | let v' = visit_var vis v in 417 | let p' = visit_pattern vis p in 418 | if v == v' && p == p' then x else MapField_Field (v', p') 419 | ) 420 | in 421 | doVisit vis (vis#vmapfield x) aux x 422 | 423 | let visit_sformal (vis: aslVisitor) (x: sformal): sformal = 424 | let aux (vis: aslVisitor) (x: sformal): sformal = 425 | (match x with 426 | | Formal_In (ty, v) -> 427 | let ty' = visit_type vis ty in 428 | let v' = visit_lvar vis v in 429 | if ty == ty' && v == v' then x else Formal_In (ty', v') 430 | | Formal_InOut(ty, v) -> 431 | let ty' = visit_type vis ty in 432 | let v' = visit_lvar vis v in 433 | if ty == ty' && v == v' then x else Formal_InOut (ty', v') 434 | ) 435 | in 436 | doVisit vis (vis#vsformal x) aux x 437 | 438 | let rec visit_dpattern (vis: aslVisitor) (x: decode_pattern): decode_pattern = 439 | let aux (vis: aslVisitor) (x: decode_pattern): decode_pattern = 440 | (match x with 441 | | DecoderPattern_Bits _ -> x 442 | | DecoderPattern_Mask _ -> x 443 | | DecoderPattern_Wildcard _ -> x 444 | | DecoderPattern_Not p -> 445 | let p' = visit_dpattern vis p in 446 | if p == p' then x else DecoderPattern_Not p' 447 | ) 448 | in 449 | doVisit vis (vis#vdpattern x) aux x 450 | 451 | let visit_encoding (vis: aslVisitor) (x: encoding): encoding = 452 | let aux (vis: aslVisitor) (x: encoding): encoding = 453 | (match x with 454 | | Encoding_Block (nm, iset, fs, op, e, ups, b, loc) -> 455 | let e' = visit_expr vis e in 456 | let b' = visit_stmts vis b in 457 | if e == e' && b == b' then x else Encoding_Block (nm, iset, fs, op, e, ups, b', loc) 458 | ) 459 | in 460 | doVisit vis (vis#vencoding x) aux x 461 | 462 | let rec visit_decode_case (vis: aslVisitor) (x: decode_case): decode_case = 463 | let aux (vis: aslVisitor) (x: decode_case): decode_case = 464 | (match x with 465 | | DecoderCase_Case (ss, alts, loc) -> 466 | let alts' = mapNoCopy (visit_decode_alt vis) alts in 467 | if alts == alts' then x else DecoderCase_Case (ss, alts', loc) 468 | ) 469 | in 470 | doVisit vis (vis#vdcase x) aux x 471 | 472 | and visit_decode_alt (vis: aslVisitor) (x: decode_alt): decode_alt = 473 | let aux (vis: aslVisitor) (x: decode_alt): decode_alt = 474 | (match x with 475 | | DecoderAlt_Alt (ps, b) -> 476 | let ps' = mapNoCopy (visit_dpattern vis) ps in 477 | let b' = visit_decode_body vis b in 478 | if ps == ps' && b == b' then x else 479 | DecoderAlt_Alt (ps', b') 480 | ) 481 | in 482 | doVisit vis (vis#vdalt x) aux x 483 | 484 | and visit_decode_body (vis: aslVisitor) (x: decode_body): decode_body = 485 | let aux (vis: aslVisitor) (x: decode_body): decode_body = 486 | (match x with 487 | | DecoderBody_UNPRED _ -> x 488 | | DecoderBody_UNALLOC _ -> x 489 | | DecoderBody_NOP _ -> x 490 | | DecoderBody_Encoding _ -> x 491 | | DecoderBody_Decoder (fs, c, loc) -> 492 | let c' = visit_decode_case vis c in 493 | if c == c' then x else DecoderBody_Decoder (fs, c', loc) 494 | ) 495 | in 496 | doVisit vis (vis#vdbody x) aux x 497 | 498 | let visit_arg (vis: aslVisitor) (x: (ty * ident)): (ty * ident) = 499 | (match x with 500 | | (ty, v) -> 501 | let ty' = visit_type vis ty in 502 | let v' = visit_var vis v in 503 | if ty == ty' && v == v' then x else 504 | (ty', v') 505 | ) 506 | 507 | let visit_args (vis: aslVisitor) (xs: (ty * ident) list): (ty * ident) list = 508 | mapNoCopy (visit_arg vis) xs 509 | 510 | let visit_decl (vis: aslVisitor) (x: declaration): declaration = 511 | let aux (vis: aslVisitor) (x: declaration): declaration = 512 | (match x with 513 | | Decl_BuiltinType (v, loc) -> 514 | let v' = visit_var vis v in 515 | if v == v' then x else 516 | Decl_BuiltinType (v', loc) 517 | | Decl_Forward (v, loc) -> 518 | let v' = visit_var vis v in 519 | if v == v' then x else 520 | Decl_Forward (v', loc) 521 | | Decl_Record (v, fs, loc) -> 522 | let v' = visit_var vis v in 523 | let fs' = visit_args vis fs in 524 | if v == v' && fs == fs' then x else 525 | Decl_Record (v', fs', loc) 526 | | Decl_Typedef (v, ty, loc) -> 527 | let v' = visit_var vis v in 528 | let ty' = visit_type vis ty in 529 | if v == v' && ty == ty' then x else 530 | Decl_Typedef (v', ty', loc) 531 | | Decl_Enum (v, es, loc) -> 532 | let v' = visit_var vis v in 533 | let es' = mapNoCopy (visit_var vis) es in 534 | if v == v' && es == es' then x else 535 | Decl_Enum (v', es', loc) 536 | | Decl_Var (ty, v, loc) -> 537 | let ty' = visit_type vis ty in 538 | let v' = visit_var vis v in 539 | if ty == ty' && v == v' then x else 540 | Decl_Var (ty', v', loc) 541 | | Decl_Const (ty, v, e, loc) -> 542 | let ty' = visit_type vis ty in 543 | let v' = visit_var vis v in 544 | let e' = visit_expr vis e in 545 | if ty == ty' && v == v' && e == e' then x else 546 | Decl_Const (ty', v', e', loc) 547 | | Decl_BuiltinFunction (ty, f, args, loc) -> 548 | let ty' = visit_type vis ty in 549 | let f' = visit_var vis f in 550 | let args' = visit_args vis args in 551 | if ty == ty' && f == f' && args == args' then x else 552 | Decl_BuiltinFunction (ty', f', args', loc) 553 | | Decl_FunType (ty, f, args, loc) -> 554 | let ty' = visit_type vis ty in 555 | let f' = visit_var vis f in 556 | let args' = visit_args vis args in 557 | if ty == ty' && f == f' && args == args' then x else 558 | Decl_FunType (ty', f', args', loc) 559 | | Decl_FunDefn (ty, f, args, b, loc) -> 560 | let ty' = visit_type vis ty in 561 | let f' = visit_var vis f in 562 | let args' = visit_args vis args in 563 | let b' = visit_stmts vis b in 564 | if ty == ty' && f == f' && args == args' && b == b' then x else 565 | Decl_FunDefn (ty', f', args', b', loc) 566 | | Decl_ProcType (f, args, loc) -> 567 | let f' = visit_var vis f in 568 | let args' = visit_args vis args in 569 | if f == f' && args == args' then x else 570 | Decl_ProcType (f', args', loc) 571 | | Decl_ProcDefn (f, args, b, loc) -> 572 | let f' = visit_var vis f in 573 | let args' = visit_args vis args in 574 | let b' = visit_stmts vis b in 575 | if f == f' && args == args' && b == b' then x else 576 | Decl_ProcDefn (f', args', b', loc) 577 | | Decl_VarGetterType (ty, f, loc) -> 578 | let ty' = visit_type vis ty in 579 | let f' = visit_var vis f in 580 | if ty == ty' && f == f' then x else 581 | Decl_VarGetterType (ty', f', loc) 582 | | Decl_VarGetterDefn (ty, f, b, loc) -> 583 | let ty' = visit_type vis ty in 584 | let f' = visit_var vis f in 585 | let b' = visit_stmts vis b in 586 | if ty == ty' && f == f' && b == b' then x else 587 | Decl_VarGetterDefn (ty', f', b', loc) 588 | | Decl_ArrayGetterType (ty, f, args, loc) -> 589 | let ty' = visit_type vis ty in 590 | let f' = visit_var vis f in 591 | let args' = visit_args vis args in 592 | if ty == ty' && f == f' && args == args' then x else 593 | Decl_ArrayGetterType (ty', f', args', loc) 594 | | Decl_ArrayGetterDefn (ty, f, args, b, loc) -> 595 | let ty' = visit_type vis ty in 596 | let f' = visit_var vis f in 597 | let args' = visit_args vis args in 598 | let b' = visit_stmts vis b in 599 | if ty == ty' && f == f' && args == args' && b == b' then x else 600 | Decl_ArrayGetterDefn (ty', f', args', b', loc) 601 | | Decl_VarSetterType (f, ty, v, loc) -> 602 | let f' = visit_var vis f in 603 | let ty' = visit_type vis ty in 604 | let v' = visit_var vis v in 605 | if f == f' && ty == ty' && v == v' then x else 606 | Decl_VarSetterType (f', ty', v', loc) 607 | | Decl_VarSetterDefn (f, ty, v, b, loc) -> 608 | let f' = visit_var vis f in 609 | let ty' = visit_type vis ty in 610 | let v' = visit_var vis v in 611 | let b' = visit_stmts vis b in 612 | if f == f' && ty == ty' && v == v' && b == b' then x else 613 | Decl_VarSetterDefn (f', ty', v', b', loc) 614 | | Decl_ArraySetterType (f, args, ty, v, loc) -> 615 | let f' = visit_var vis f in 616 | let args' = mapNoCopy (visit_sformal vis) args in 617 | let ty' = visit_type vis ty in 618 | let v' = visit_var vis v in 619 | if f == f' && args == args' && ty == ty' && v == v' then x else 620 | Decl_ArraySetterType (f', args', ty', v', loc) 621 | | Decl_ArraySetterDefn (f, args, ty, v, b, loc) -> 622 | let f' = visit_var vis f in 623 | let args' = mapNoCopy (visit_sformal vis) args in 624 | let ty' = visit_type vis ty in 625 | let v' = visit_var vis v in 626 | let b' = visit_stmts vis b in 627 | if f == f' && args == args' && ty == ty' && v == v' && b == b' then x else 628 | Decl_ArraySetterDefn (f', args', ty', v', b', loc) 629 | | Decl_InstructionDefn (d, es, opd, c, ex, loc) -> 630 | let d' = visit_var vis d in 631 | let es' = mapNoCopy (visit_encoding vis) es in 632 | let opd' = mapOptionNoCopy (visit_stmts vis) opd in 633 | let ex' = visit_stmts vis ex in 634 | if d == d' && es == es' && opd == opd' && ex == ex' then x else 635 | Decl_InstructionDefn (d', es', opd', c, ex', loc) 636 | | Decl_DecoderDefn (d, dc, loc) -> 637 | let d' = visit_var vis d in 638 | let dc' = visit_decode_case vis dc in 639 | if d == d' && dc == dc' then x else 640 | Decl_DecoderDefn (d', dc', loc) 641 | | Decl_Operator1 (op, vs, loc) -> 642 | let vs' = mapNoCopy (visit_var vis) vs in 643 | if vs == vs' then x else 644 | Decl_Operator1 (op, vs', loc) 645 | | Decl_Operator2 (op, vs, loc) -> 646 | let vs' = mapNoCopy (visit_var vis) vs in 647 | if vs == vs' then x else 648 | Decl_Operator2 (op, vs', loc) 649 | | Decl_NewEventDefn(v, args, loc) -> 650 | let v' = visit_var vis v in 651 | let args' = visit_args vis args in 652 | if v == v' && args == args' then x else 653 | Decl_NewEventDefn(v', args', loc) 654 | | Decl_EventClause(v, b, loc) -> 655 | let v' = visit_var vis v in 656 | let b' = visit_stmts vis b in 657 | if v == v' && b == b' then x else 658 | Decl_EventClause(v', b', loc) 659 | | Decl_NewMapDefn(ty, v, args, b, loc) -> 660 | let ty' = visit_type vis ty in 661 | let v' = visit_var vis v in 662 | let args' = visit_args vis args in 663 | let b' = visit_stmts vis b in 664 | if v == v' && args == args' && b == b' then x else 665 | Decl_NewMapDefn(ty', v', args', b', loc) 666 | | Decl_MapClause(v, fs, oc, b, loc) -> 667 | let v' = visit_var vis v in 668 | let fs' = mapNoCopy (visit_mapfield vis) fs in 669 | let oc' = mapOptionNoCopy (visit_expr vis) oc in 670 | let b' = visit_stmts vis b in 671 | if v == v' && fs == fs' && oc == oc' && b == b' then x else 672 | Decl_MapClause(v', fs', oc', b', loc) 673 | | Decl_Config(ty, v, e, loc) -> 674 | let ty' = visit_type vis ty in 675 | let v' = visit_var vis v in 676 | let e' = visit_expr vis e in 677 | if ty == ty' && v == v' && e == e' then x else 678 | Decl_Config(ty', v', e', loc) 679 | ) 680 | 681 | in 682 | doVisit vis (vis#vdecl x) aux x 683 | 684 | 685 | (****************************************************************) 686 | (** {2 nopAslVisitor class} *) 687 | (****************************************************************) 688 | 689 | (** The nopAslVisitor class defines a visitor that recursively 690 | visits the entire tree making no change. 691 | In practice, all uses of the visitor framework are based on defining 692 | a subclass of this type. 693 | *) 694 | 695 | class nopAslVisitor : aslVisitor = object 696 | 697 | method vvar (x: ident) = DoChildren 698 | method ve_elsif (x: e_elsif) = DoChildren 699 | method vslice (x: slice) = DoChildren 700 | method vpattern (x: pattern) = DoChildren 701 | method vexpr (x: expr) = DoChildren 702 | method vtype (x: ty) = DoChildren 703 | method vlvar (x: ident) = DoChildren 704 | method vlexpr (x: lexpr) = DoChildren 705 | method vstmt (x: stmt) = DoChildren 706 | method vs_elsif (x: s_elsif) = DoChildren 707 | method valt (x: alt) = DoChildren 708 | method vcatcher (x: catcher) = DoChildren 709 | method vmapfield (x: mapfield) = DoChildren 710 | method vsformal (x: sformal) = DoChildren 711 | method vdpattern (x: decode_pattern) = DoChildren 712 | method vencoding (x: encoding) = DoChildren 713 | method vdcase (x: decode_case) = DoChildren 714 | method vdalt (x: decode_alt) = DoChildren 715 | method vdbody (x: decode_body) = DoChildren 716 | method vdecl (x: declaration) = DoChildren 717 | 718 | end 719 | 720 | (**************************************************************** 721 | * End 722 | ****************************************************************) 723 | -------------------------------------------------------------------------------- /asli.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * ASL interactive frontend 3 | * 4 | * Copyright Arm Limited (c) 2017-2019 5 | * SPDX-Licence-Identifier: BSD-3-Clause 6 | ****************************************************************) 7 | 8 | (** ASL interactive frontend *) 9 | 10 | open Asl_ast 11 | 12 | module Lexer = Lexer 13 | module Parser = Asl_parser 14 | module TC = Tcheck 15 | module PP = Asl_parser_pp 16 | module AST = Asl_ast 17 | 18 | open Lexersupport 19 | open Lexing 20 | 21 | let opt_filenames : string list ref = ref [] 22 | let opt_print_version = ref false 23 | let opt_verbose = ref false 24 | 25 | let read_file (filename : string) (isPrelude: bool): AST.declaration list = 26 | if !opt_verbose then Printf.printf "Processing %s\n" filename; 27 | let inchan = open_in filename in 28 | let lexbuf = Lexing.from_channel inchan in 29 | lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; 30 | let t = 31 | (try 32 | (* Apply offside rule to raw token stream *) 33 | let lexer = offside_token Lexer.token in 34 | 35 | (* Run the parser on this line of input. *) 36 | if !opt_verbose then Printf.printf "- Parsing %s\n" filename; 37 | Parser.declarations_start lexer lexbuf 38 | with 39 | | Parse_error_locn(l, s) -> begin 40 | Printf.printf " Syntax error %s at %s\n" s (pp_loc l); 41 | exit 1 42 | end 43 | | PrecedenceError(loc, op1, op2) -> begin 44 | Printf.printf " Syntax error: operators %s and %s require parentheses to disambiguate expression at location %s\n" 45 | (Utils.to_string (Asl_parser_pp.pp_binop op1)) 46 | (Utils.to_string (Asl_parser_pp.pp_binop op2)) 47 | (pp_loc loc); 48 | exit 1 49 | end 50 | | Parser.Error -> begin 51 | let curr = lexbuf.Lexing.lex_curr_p in 52 | let tok = Lexing.lexeme lexbuf in 53 | Printf.printf " Parser error at %s '%s'\n" (AST.pp_lexing_position curr) tok; 54 | exit 1 55 | end 56 | ) 57 | in 58 | close_in inchan; 59 | 60 | if false then PPrint.ToChannel.pretty 1.0 60 stdout (PP.pp_declarations t); 61 | if !opt_verbose then Printf.printf " - Got %d declarations from %s\n" (List.length t) filename; 62 | 63 | let t' = 64 | try 65 | if !opt_verbose then Printf.printf "- Typechecking %s\n" filename; 66 | let t' = TC.tc_declarations isPrelude t in 67 | t' 68 | with 69 | | TC.UnknownObject (loc, what, x) -> 70 | Printf.printf " %s: Type error: Unknown %s %s\n" (pp_loc loc) what x; 71 | exit 1 72 | | TC.DoesNotMatch (loc, what, x, y) -> 73 | Printf.printf " %s: Type error: %s %s does not match %s\n" (pp_loc loc) what x y; 74 | exit 1 75 | | TC.IsNotA (loc, what, x) -> 76 | Printf.printf " %s: Type error: %s is not a %s\n" (pp_loc loc) x what; 77 | exit 1 78 | | TC.Ambiguous (loc, what, x) -> 79 | Printf.printf " %s: Type error: %s %s is ambiguous\n" (pp_loc loc) what x; 80 | exit 1 81 | | TC.TypeError (loc, what) -> 82 | Printf.printf " %s: Type error: %s\n" (pp_loc loc) what; 83 | exit 1 84 | in 85 | 86 | if false then PPrint.ToChannel.pretty 1.0 60 stdout (PP.pp_declarations t'); 87 | if !opt_verbose then Printf.printf " - Got %d typechecked declarations from %s\n" (List.length t') filename; 88 | 89 | if !opt_verbose then Printf.printf "Finished %s\n" filename; 90 | flush stdout; 91 | t' 92 | 93 | let read_spec (filename : string): AST.declaration list = 94 | let r: AST.declaration list list ref = ref [] in 95 | let inchan = open_in filename in 96 | (try 97 | while true do 98 | let t = read_file (input_line inchan) false in 99 | r := t :: !r 100 | done 101 | with 102 | | End_of_file -> 103 | close_in inchan 104 | ); 105 | List.concat (List.rev !r) 106 | 107 | let help_msg = [ 108 | {|:? :help Show this help message|}; 109 | {|:opcode Decode and execute opcode|}; 110 | {|:project Execute ASLi commands in |}; 111 | {|:q :quit Exit the interpreter|}; 112 | {|:set impdef = Define implementation defined behavior|}; 113 | {|:set + Set flag|}; 114 | {|:set - Clear flag|}; 115 | {| Execute ASL expression|}; 116 | {| ; Execute ASL statement|} 117 | ] 118 | 119 | let flags = [ 120 | ("trace:write", Eval.trace_write); 121 | ("trace:fun", Eval.trace_funcall); 122 | ("trace:prim", Eval.trace_primop); 123 | ("trace:instr", Eval.trace_instruction) 124 | ] 125 | 126 | let mkLoc (fname: string) (input: string): AST.l = 127 | let len = String.length input in 128 | let start : Lexing.position = { pos_fname = fname; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } in 129 | let finish: Lexing.position = { pos_fname = fname; pos_lnum = 1; pos_bol = 0; pos_cnum = len } in 130 | AST.Range (start, finish) 131 | 132 | let rec process_command (tcenv: TC.Env.t) (env: Eval.Env.t) (fname: string) (input0: string): unit = 133 | let input = String.trim input0 in 134 | (match String.split_on_char ' ' input with 135 | | [""] -> 136 | () 137 | | [":help"] | [":?"] -> 138 | List.iter print_endline help_msg; 139 | print_endline "\nFlags:"; 140 | List.iter (fun (nm, v) -> Printf.printf " %s%s\n" (if !v then "+" else "-") nm) flags 141 | | [":opcode"; iset; opcode] -> 142 | (* todo: make this code more robust *) 143 | let op = Value.VBits (Primops.prim_cvt_int_bits (Z.of_int 32) (Z.of_int (int_of_string opcode))) in 144 | Printf.printf "Decoding and executing instruction %s %s\n" iset (Value.pp_value op); 145 | let decoder = Eval.Env.getDecoder env (Ident iset) in 146 | Eval.eval_decode_case AST.Unknown env decoder op 147 | | (":set" :: "impdef" :: rest) -> 148 | let cmd = String.concat " " rest in 149 | let loc = mkLoc fname cmd in 150 | let lexbuf = Lexing.from_string cmd in 151 | let lexer = offside_token Lexer.token in 152 | let CLI_Impdef (x, e) = Parser.impdef_command_start lexer lexbuf in 153 | let (s, e') = TC.with_unify tcenv loc (fun u -> 154 | let (e', _) = TC.tc_expr tcenv u loc e in 155 | e' 156 | ) in 157 | let e'' = TC.unify_subst_e s e' in 158 | let v = Eval.eval_expr loc env e'' in 159 | Eval.Env.setImpdef env x v 160 | | [":set"; flag] when Utils.startswith flag "+" -> 161 | (match List.assoc_opt (Utils.stringDrop 1 flag) flags with 162 | | None -> Printf.printf "Unknown flag %s\n" flag; 163 | | Some f -> f := true 164 | ) 165 | | [":set"; flag] when Utils.startswith flag "-" -> 166 | (match List.assoc_opt (Utils.stringDrop 1 flag) flags with 167 | | None -> Printf.printf "Unknown flag %s\n" flag; 168 | | Some f -> f := false 169 | ) 170 | | [":project"; prj] -> 171 | let inchan = open_in prj in 172 | (try 173 | while true do 174 | process_command tcenv env prj (input_line inchan) 175 | done 176 | with 177 | | End_of_file -> 178 | close_in inchan 179 | ) 180 | | [":q"] | [":quit"] -> 181 | exit 0 182 | | _ -> 183 | let loc = mkLoc fname input in 184 | let lexbuf = Lexing.from_string input in 185 | let lexer = offside_token Lexer.token in 186 | if ';' = String.get input (String.length input - 1) then begin 187 | let s = Parser.stmt_command_start lexer lexbuf in 188 | let s' = TC.tc_stmt tcenv s in 189 | Eval.eval_stmt env s' 190 | end else begin 191 | let e = Parser.expr_command_start lexer lexbuf in 192 | let (s, e') = TC.with_unify tcenv loc (fun u -> 193 | let (e', _) = TC.tc_expr tcenv u loc e in 194 | e' 195 | ) in 196 | let e'' = TC.unify_subst_e s e' in 197 | let v = Eval.eval_expr loc env e'' in 198 | print_endline (Value.pp_value v) 199 | end 200 | ) 201 | 202 | let try_process_command (tcenv: TC.Env.t) (env: Eval.Env.t) (fname: string) (input: string): unit = 203 | (try 204 | process_command tcenv env fname input 205 | with 206 | | Parse_error_locn(l, s) -> begin 207 | Printf.printf " Syntax error %s at %s\n" s (pp_loc l) 208 | end 209 | | PrecedenceError(loc, op1, op2) -> begin 210 | Printf.printf " Syntax error: operators %s and %s require parentheses to disambiguate expression at location %s\n" 211 | (Utils.to_string (Asl_parser_pp.pp_binop op1)) 212 | (Utils.to_string (Asl_parser_pp.pp_binop op2)) 213 | (pp_loc loc) 214 | end 215 | | Parser.Error -> 216 | Printf.printf " Parser error\n"; 217 | | TC.UnknownObject (loc, what, x) -> 218 | Printf.printf " %s: Type error: Unknown %s %s\n" (pp_loc loc) what x 219 | | TC.DoesNotMatch (loc, what, x, y) -> 220 | Printf.printf " %s: Type error: %s %s does not match %s\n" (pp_loc loc) what x y 221 | | TC.IsNotA (loc, what, x) -> 222 | Printf.printf " %s: Type error: %s is not a %s\n" (pp_loc loc) x what 223 | | TC.Ambiguous (loc, what, x) -> 224 | Printf.printf " %s: Type error: %s %s is ambiguous\n" (pp_loc loc) what x 225 | | TC.TypeError (loc, what) -> 226 | Printf.printf " %s: Type error: %s\n" (pp_loc loc) what 227 | | Value.EvalError (loc, msg) -> 228 | Printf.printf " %s: Evaluation error: %s\n" (pp_loc loc) msg 229 | | exc -> 230 | Printf.printf " Error %s\n" (Printexc.to_string exc); 231 | Printexc.print_backtrace stdout 232 | ) 233 | 234 | let rec repl (tcenv: TC.Env.t) (env: Eval.Env.t): unit = 235 | flush stdout; 236 | (match LNoise.linenoise "ASLi> " with 237 | | None -> () 238 | | Some input -> 239 | LNoise.history_add input |> ignore; 240 | try_process_command tcenv env "" input; 241 | repl tcenv env 242 | ) 243 | 244 | let options = Arg.align ([ 245 | ( "-v", Arg.Set opt_verbose, " Verbose output"); 246 | ( "--version", Arg.Set opt_print_version, " Print version"); 247 | ] ) 248 | 249 | let version = "ASL 0.0 alpha" 250 | 251 | let banner = [ 252 | {| _____ _ _ ___________________________________|}; 253 | {| /\ / ____|| | (_) ASL interpreter |}; 254 | {| / \ | (___ | | _ Copyright Arm Limited (c) 2017-2019|}; 255 | {| / /\ \ \___ \ | | | | |}; 256 | {| / ____ \ ____) || |____ | | |} ^ version; 257 | {|/_/ \_\|_____/ |______||_| ___________________________________|} 258 | ] 259 | let usage_msg = 260 | ( version 261 | ^ "\nusage: asl ... \n" 262 | ) 263 | 264 | let _ = 265 | Arg.parse options 266 | (fun s -> opt_filenames := (!opt_filenames) @ [s]) 267 | usage_msg 268 | 269 | let main () = 270 | if !opt_print_version then Printf.printf "%s\n" version 271 | else begin 272 | List.iter print_endline banner; 273 | print_endline "\nType :? for help"; 274 | let t = read_file "prelude.asl" true in 275 | let ts = List.map (fun filename -> 276 | if Utils.endswith filename ".spec" then begin 277 | read_spec filename 278 | end else if Utils.endswith filename ".asl" then begin 279 | read_file filename false 280 | end else begin 281 | failwith ("Unrecognized file suffix on "^filename) 282 | end 283 | ) !opt_filenames 284 | in 285 | 286 | if !opt_verbose then Printf.printf "Building evaluation environment\n"; 287 | let env = (try 288 | Eval.build_evaluation_environment (List.concat (t::ts)) 289 | with 290 | | Value.EvalError (loc, msg) -> 291 | Printf.printf " %s: Evaluation error: %s\n" (pp_loc loc) msg; 292 | exit 1 293 | ) in 294 | if !opt_verbose then Printf.printf "Built evaluation environment\n"; 295 | 296 | LNoise.history_load ~filename:"asl_history" |> ignore; 297 | LNoise.history_set ~max_length:100 |> ignore; 298 | repl (TC.Env.mkEnv TC.env0) env 299 | end 300 | 301 | let _ =ignore(main ()) 302 | 303 | (**************************************************************** 304 | * End 305 | ****************************************************************) 306 | -------------------------------------------------------------------------------- /asli.odocl: -------------------------------------------------------------------------------- 1 | Asl_ast 2 | Asl_utils 3 | Asl_visitor 4 | Asli 5 | Eval 6 | Lexersupport 7 | Primops 8 | Tcheck 9 | Testlexer 10 | Utils 11 | Value 12 | Visitor 13 | -------------------------------------------------------------------------------- /eval.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * ASL evaluator 3 | * 4 | * Copyright Arm Limited (c) 2017-2019 5 | * SPDX-Licence-Identifier: BSD-3-Clause 6 | ****************************************************************) 7 | 8 | (** ASL evaluator *) 9 | 10 | module PP = Asl_parser_pp 11 | module AST = Asl_ast 12 | module TC = Tcheck 13 | 14 | open AST 15 | open Printf 16 | open Utils 17 | open Asl_utils 18 | open Value 19 | 20 | (**************************************************************** 21 | * Flags to control behaviour (mostly for debugging) 22 | ****************************************************************) 23 | 24 | (** Debugging output on every variable write *) 25 | let trace_write = ref false 26 | 27 | (** Debugging output on every function call *) 28 | let trace_funcall = ref false 29 | 30 | (** Debugging output on every primitive function or function call *) 31 | let trace_primop = ref false 32 | 33 | (** Debugging output on every instruction execution *) 34 | let trace_instruction = ref false 35 | 36 | 37 | (** It is an error to have multiple function definitions with conflicting types. 38 | * But, for historical reasons, we still allow multiple definitions and later 39 | * definitions override earlier definitions. 40 | *) 41 | let override_conflicts = true 42 | 43 | 44 | (****************************************************************) 45 | (** {2 Lookup table for IMPLEMENTATION_DEFINED values} *) 46 | (****************************************************************) 47 | 48 | module ImpDefs = struct 49 | include Map.Make(struct 50 | type t = string 51 | let compare = String.compare 52 | end) 53 | end 54 | 55 | 56 | (****************************************************************) 57 | (** {2 Scopes} *) 58 | (****************************************************************) 59 | 60 | (** Basically just a mutable binding *) 61 | type scope = { mutable bs : value Bindings.t; } 62 | 63 | let empty_scope (_: unit): scope = 64 | let bs = Bindings.empty in 65 | { bs } 66 | 67 | let mem_scope (k: ident) (s: scope): bool = 68 | Bindings.mem k s.bs 69 | 70 | let get_scope (k: ident) (s: scope): value = 71 | Bindings.find k s.bs 72 | 73 | let get_scope_opt (k: ident) (s: scope): value option = 74 | Bindings.find_opt k s.bs 75 | 76 | let set_scope (k: ident) (v: value) (s: scope): unit = 77 | s.bs <- Bindings.add k v s.bs 78 | 79 | 80 | (****************************************************************) 81 | (** {2 Mutable bindings} *) 82 | (****************************************************************) 83 | 84 | (** Environment representing both global and local state of the system *) 85 | module Env : sig 86 | type t 87 | val empty : t 88 | val nestTop : (t -> 'a) -> (t -> 'a) 89 | val nest : (t -> 'a) -> (t -> 'a) 90 | 91 | val addLocalVar : AST.l -> t -> ident -> value -> unit 92 | val addLocalConst : AST.l -> t -> ident -> value -> unit 93 | 94 | val addGlobalConst : t -> ident -> value -> unit 95 | val getGlobalConst : t -> ident -> value 96 | 97 | (* to support generation of unknown values, we need to remember the structure 98 | * of user-defined types such as enumerations and records 99 | *) 100 | val addEnum : t -> ident -> value list -> unit 101 | val getEnum : t -> ident -> (value list) option 102 | val isEnumEq : t -> ident -> bool 103 | val isEnumNeq : t -> ident -> bool 104 | 105 | val addRecord : t -> ident -> (AST.ty * ident) list -> unit 106 | val getRecord : t -> ident -> (AST.ty * ident) list option 107 | 108 | val addTypedef : t -> ident -> AST.ty -> unit 109 | val getTypedef : t -> ident -> AST.ty option 110 | 111 | val addGlobalVar : t -> ident -> value -> unit 112 | val getVar : AST.l -> t -> ident -> value 113 | val setVar : AST.l -> t -> ident -> value -> unit 114 | 115 | val getFun : AST.l -> t -> ident -> (ident list * ident list * AST.l * stmt list) 116 | val addFun : AST.l -> t -> ident -> (ident list * ident list * AST.l * stmt list) -> unit 117 | 118 | val getInstruction : AST.l -> t -> ident -> (encoding * (stmt list) option * bool * stmt list) 119 | val addInstruction : AST.l -> t -> ident -> (encoding * (stmt list) option * bool * stmt list) -> unit 120 | 121 | val getDecoder : t -> ident -> decode_case 122 | val addDecoder : t -> ident -> decode_case -> unit 123 | 124 | val setImpdef : t -> string -> value -> unit 125 | val getImpdef : AST.l -> t -> string -> value 126 | 127 | end = struct 128 | type t = { 129 | mutable instructions : (encoding * (stmt list) option * bool * stmt list) Bindings.t; 130 | mutable decoders : decode_case Bindings.t; 131 | mutable functions : (ident list * ident list * AST.l * stmt list) Bindings.t; 132 | mutable enums : (value list) Bindings.t; 133 | mutable enumEqs : IdentSet.t; 134 | mutable enumNeqs : IdentSet.t; 135 | mutable records : ((AST.ty * ident) list) Bindings.t; 136 | mutable typedefs : AST.ty Bindings.t; 137 | mutable globals : scope; 138 | mutable constants : scope; 139 | mutable impdefs : value ImpDefs.t; 140 | mutable locals : scope list 141 | } 142 | 143 | let empty = { 144 | decoders = Bindings.empty; 145 | instructions = Bindings.empty; 146 | functions = Bindings.empty; 147 | enums = Bindings.empty; 148 | enumEqs = IdentSet.empty; 149 | enumNeqs = IdentSet.empty; 150 | records = Bindings.empty; 151 | typedefs = Bindings.empty; 152 | globals = empty_scope (); 153 | constants = empty_scope (); 154 | impdefs = ImpDefs.empty; 155 | locals = [empty_scope ()]; 156 | } 157 | 158 | let nestTop (k: t -> 'a) (parent: t): 'a = 159 | let child = { 160 | decoders = parent.decoders; 161 | instructions = parent.instructions; 162 | functions = parent.functions; 163 | enums = parent.enums; 164 | enumEqs = parent.enumEqs; 165 | enumNeqs = parent.enumNeqs; 166 | records = parent.records; 167 | typedefs = parent.typedefs; 168 | globals = parent.globals; 169 | constants = parent.constants; 170 | impdefs = parent.impdefs; 171 | locals = [empty_scope ()]; (* only change *) 172 | } in 173 | k child 174 | 175 | let nest (k: t -> 'a) (parent: t): 'a = 176 | let child = { 177 | decoders = parent.decoders; 178 | instructions = parent.instructions; 179 | functions = parent.functions; 180 | enums = parent.enums; 181 | enumEqs = parent.enumEqs; 182 | enumNeqs = parent.enumNeqs; 183 | records = parent.records; 184 | typedefs = parent.typedefs; 185 | globals = parent.globals; 186 | constants = parent.constants; 187 | impdefs = parent.impdefs; 188 | locals = empty_scope () :: parent.locals; (* only change *) 189 | } in 190 | k child 191 | 192 | let addLocalVar (loc: l) (env: t) (x: ident) (v: value): unit = 193 | if !trace_write then Printf.printf "TRACE: fresh %s = %s\n" (pprint_ident x) (pp_value v); 194 | (match env.locals with 195 | | (bs :: _) -> set_scope x v bs 196 | | [] -> raise (EvalError (loc, "addLocalVar")) 197 | ) 198 | 199 | let addLocalConst (loc: l) (env: t) (x: ident) (v: value): unit = 200 | (* todo: should constants be held separately from local vars? *) 201 | (match env.locals with 202 | | (bs :: _) -> set_scope x v bs 203 | | [] -> raise (EvalError (loc, "addLocalConst")) 204 | ) 205 | 206 | let addGlobalConst (env: t) (x: ident) (v: value): unit = 207 | set_scope x v env.constants 208 | 209 | let getGlobalConst (env: t) (x: ident): value = 210 | get_scope x env.constants 211 | 212 | let addEnum (env: t) (x: ident) (vs: value list): unit = 213 | env.enums <- Bindings.add x vs env.enums 214 | 215 | let getEnum (env: t) (x: ident): (value list) option = 216 | Bindings.find_opt x env.enums 217 | 218 | let isEnumEq (env: t) (x: ident): bool = IdentSet.mem x env.enumEqs 219 | let isEnumNeq (env: t) (x: ident): bool = IdentSet.mem x env.enumNeqs 220 | 221 | let addRecord (env: t) (x: ident) (fs: (AST.ty * ident) list): unit = 222 | env.records <- Bindings.add x fs env.records 223 | 224 | let getRecord (env: t) (x: ident): ((AST.ty * ident) list) option = 225 | Bindings.find_opt x env.records 226 | 227 | let addTypedef (env: t) (x: ident) (ty: AST.ty): unit = 228 | env.typedefs <- Bindings.add x ty env.typedefs 229 | 230 | let getTypedef (env: t) (x: ident): AST.ty option = 231 | Bindings.find_opt x env.typedefs 232 | 233 | let addGlobalVar (env: t) (x: ident) (v: value): unit = 234 | set_scope x v env.globals 235 | 236 | let findScope (env: t) (x: ident): scope option = 237 | let rec search (bss : scope list): scope option = 238 | (match bss with 239 | | (bs :: bss') -> 240 | if mem_scope x bs then Some bs else search bss' 241 | | [] -> 242 | if mem_scope x env.globals then Some env.globals 243 | else if mem_scope x env.constants then Some env.constants 244 | else None 245 | ) 246 | in 247 | search env.locals 248 | 249 | let getVar (loc: l) (env: t) (x: ident): value = 250 | (match findScope env x with 251 | | Some bs -> get_scope x bs 252 | | None -> raise (EvalError (loc, "getVar: " ^ pprint_ident x)) 253 | ) 254 | 255 | let setVar (loc: l) (env: t) (x: ident) (v: value): unit = 256 | if !trace_write then Printf.printf "TRACE: write %s = %s\n" (pprint_ident x) (pp_value v); 257 | (match findScope env x with 258 | | Some bs -> set_scope x v bs 259 | | None -> raise (EvalError (loc, "setVar " ^ pprint_ident x)) 260 | ) 261 | 262 | let getFun (loc: l) (env: t) (x: ident): (ident list * ident list * AST.l * stmt list) = 263 | (match Bindings.find_opt x env.functions with 264 | | Some def -> def 265 | | None -> raise (EvalError (loc, "getFun " ^ pprint_ident x)) 266 | ) 267 | 268 | let addFun (loc: l) (env: t) (x: ident) (def: (ident list * ident list * AST.l * stmt list)): unit = 269 | if false then Printf.printf "Adding function %s\n" (pprint_ident x); 270 | if Bindings.mem x env.functions then begin 271 | if true then begin 272 | () (* silently override *) 273 | end else if override_conflicts then begin 274 | (* backward compatibility mode: only report a stern warning *) 275 | Printf.printf "Stern warning: %s function %s conflicts with earlier definition - discarding earlier definition\n" 276 | (pp_loc loc) (pprint_ident x); 277 | end else begin 278 | raise (TC.Ambiguous (loc, "function definition", pprint_ident x)) 279 | end 280 | end; 281 | env.functions <- Bindings.add x def env.functions 282 | 283 | let getInstruction (loc: AST.l) (env: t) (x: ident): (encoding * (stmt list) option * bool * stmt list) = 284 | Bindings.find x env.instructions 285 | 286 | let addInstruction (loc: AST.l) (env: t) (x: ident) (instr: encoding * (stmt list) option * bool * stmt list): unit = 287 | env.instructions <- Bindings.add x instr env.instructions 288 | 289 | let getDecoder (env: t) (x: ident): decode_case = 290 | Bindings.find x env.decoders 291 | 292 | let addDecoder (env: t) (x: ident) (d: decode_case): unit = 293 | env.decoders <- Bindings.add x d env.decoders 294 | 295 | let setImpdef (env: t) (x: string) (v: value): unit = 296 | env.impdefs <- ImpDefs.add x v env.impdefs 297 | 298 | let getImpdef (loc: l) (env: t) (x: string): value = 299 | (match ImpDefs.find_opt x env.impdefs with 300 | | Some v -> v 301 | | None -> 302 | raise (EvalError (loc, "Unknown value for IMPLEMENTATION_DEFINED \""^x^"\"")) 303 | ) 304 | end 305 | 306 | 307 | (****************************************************************) 308 | (** {2 Evaluation functions} *) 309 | (****************************************************************) 310 | 311 | (** Evaluate list of expressions *) 312 | let rec eval_exprs (loc: l) (env: Env.t) (xs: AST.expr list): value list = 313 | List.map (eval_expr loc env) xs 314 | 315 | (** Create uninitialized value at given type 316 | 317 | - For any scalar type, this is the value VUninitialized. 318 | - For any composite type, all elements are set to uninitialized values 319 | 320 | todo: bitvectors are currently set to UNKNOWN because the bitvector 321 | representation currently in use cannot track uninitialized bits 322 | *) 323 | and mk_uninitialized (loc: l) (env: Env.t) (x: AST.ty): value = 324 | ( match x with 325 | | Type_Constructor(tc) -> 326 | (match Env.getRecord env tc with 327 | | Some fs -> 328 | mkrecord (List.map (fun (ty, f) -> (f, mk_uninitialized loc env ty)) fs) 329 | | None -> 330 | (match Env.getTypedef env tc with 331 | | Some ty' -> mk_uninitialized loc env ty' 332 | | None -> VUninitialized 333 | ) 334 | ) 335 | | Type_Array(Index_Enum(tc),ety) -> 336 | Value.empty_array (mk_uninitialized loc env ety) 337 | | Type_Array(Index_Range(lo,hi),ety) -> 338 | Value.empty_array (mk_uninitialized loc env ety) 339 | | Type_Tuple(tys) -> 340 | VTuple (List.map (mk_uninitialized loc env) tys) 341 | (* bitvectors and registers should really track whether a bit is initialized individually *) 342 | | Type_Bits(n) -> eval_unknown_bits (to_integer loc (eval_expr loc env n)) 343 | | Type_Register(wd, _) -> eval_unknown_bits (Z.of_string wd) 344 | | _ -> 345 | VUninitialized (* should only be used for scalar types *) 346 | ) 347 | 348 | (** Evaluate UNKNOWN at given type *) 349 | and eval_unknown (loc: l) (env: Env.t) (x: AST.ty): value = 350 | ( match x with 351 | | Type_Constructor(Ident "integer") -> eval_unknown_integer () 352 | | Type_Constructor(Ident "real") -> eval_unknown_real () 353 | | Type_Constructor(Ident "string") -> eval_unknown_string () 354 | | Type_Constructor(tc) -> 355 | (match Env.getEnum env tc with 356 | | Some (e::_) -> e 357 | | Some [] -> raise (EvalError (loc, "eval_unknown unknown type constructor " ^ Utils.to_string (PP.pp_ty x))) 358 | | None -> 359 | (match Env.getRecord env tc with 360 | | Some fs -> 361 | mkrecord (List.map (fun (ty, f) -> (f, eval_unknown loc env ty)) fs) 362 | | None -> 363 | (match Env.getTypedef env tc with 364 | | Some ty' -> eval_unknown loc env ty' 365 | | None -> 366 | raise (EvalError (loc, "eval_unknown " ^ Utils.to_string (PP.pp_ty x))) 367 | ) 368 | ) 369 | ) 370 | | Type_Bits(n) -> eval_unknown_bits (to_integer loc (eval_expr loc env n)) 371 | | Type_App(Ident "__RAM", [a]) -> 372 | let a' = to_integer loc (eval_expr loc env a) in 373 | eval_unknown_ram a' 374 | | Type_App(tc, es) -> 375 | raise (EvalError (loc, "eval_unknown App " ^ Utils.to_string (PP.pp_ty x))) 376 | | Type_OfExpr(e) -> 377 | raise (EvalError (loc, "eval_unknown typeof " ^ Utils.to_string (PP.pp_ty x))) 378 | | Type_Register(wd, _) -> eval_unknown_bits (Z.of_string wd) 379 | | Type_Array(Index_Enum(tc),ety) -> 380 | Value.empty_array (eval_unknown loc env ety) 381 | | Type_Array(Index_Range(lo,hi),ety) -> 382 | Value.empty_array (eval_unknown loc env ety) 383 | | Type_Tuple(tys) -> 384 | VTuple (List.map (eval_unknown loc env) tys) 385 | ) 386 | 387 | (** Evaluate pattern match *) 388 | and eval_pattern (loc: l) (env: Env.t) (v: value) (x: AST.pattern): bool = 389 | ( match x with 390 | | Pat_LitInt(l) -> eval_eq_int loc v (from_intLit l) 391 | | Pat_LitHex(l) -> eval_eq_int loc v (from_hexLit l) 392 | | Pat_LitBits(l) -> eval_eq_bits loc v (from_bitsLit l) 393 | | Pat_LitMask(l) -> eval_inmask loc v (from_maskLit l) 394 | | Pat_Const(c) -> eval_eq loc v (Env.getGlobalConst env c) 395 | | Pat_Wildcard -> true 396 | | Pat_Tuple(ps) -> 397 | let vs = of_tuple loc v in 398 | assert (List.length vs = List.length ps); 399 | List.for_all2 (eval_pattern loc env) vs ps 400 | | Pat_Set(ps) -> 401 | List.exists (eval_pattern loc env v) ps 402 | | Pat_Single(e) -> 403 | let v' = eval_expr loc env e in 404 | eval_eq loc v v' 405 | | Pat_Range(lo, hi) -> 406 | let lo' = eval_expr loc env lo in 407 | let hi' = eval_expr loc env hi in 408 | eval_leq loc lo' v && eval_leq loc v hi' 409 | ) 410 | 411 | (** Evaluate bitslice bounds *) 412 | and eval_slice (loc: l) (env: Env.t) (x: AST.slice): (value * value) = 413 | (match x with 414 | | Slice_Single(i) -> 415 | let i' = eval_expr loc env i in 416 | (i', VInt Z.one) 417 | | Slice_HiLo(hi, lo) -> 418 | let hi' = eval_expr loc env hi in 419 | let lo' = eval_expr loc env lo in 420 | let wd' = eval_add_int loc (eval_sub_int loc hi' lo') (VInt Z.one) in 421 | (lo', wd') 422 | | Slice_LoWd(lo, wd) -> 423 | let lo' = eval_expr loc env lo in 424 | let wd' = eval_expr loc env wd in 425 | (lo', wd') 426 | ) 427 | 428 | (** Evaluate expression *) 429 | and eval_expr (loc: l) (env: Env.t) (x: AST.expr): value = 430 | (match x with 431 | | Expr_If(c, t, els, e) -> 432 | let rec eval_if xs d = match xs with 433 | | [] -> eval_expr loc env d 434 | | AST.E_Elsif_Cond (cond, b)::xs' -> 435 | if to_bool loc (eval_expr loc env cond) then 436 | eval_expr loc env b 437 | else 438 | eval_if xs' d 439 | in 440 | eval_if (E_Elsif_Cond(c, t)::els) e 441 | | Expr_Binop(a, op, b) -> 442 | raise (EvalError (loc, "binary operation should have been removed in expression " 443 | ^ Utils.to_string (PP.pp_expr x))) 444 | | Expr_Field(e, f) -> 445 | get_field loc (eval_expr loc env e) f 446 | | Expr_Fields(e, fs) -> 447 | let v = eval_expr loc env e in 448 | let vs = List.map (get_field loc v) fs in 449 | eval_concat loc vs 450 | | Expr_Slices(e, ss) -> 451 | let v = eval_expr loc env e in 452 | let vs = List.map (fun s -> 453 | let (i, w) = eval_slice loc env s in 454 | extract_bits'' loc v i w 455 | ) ss in 456 | eval_concat loc vs 457 | | Expr_In(e, p) -> 458 | from_bool (eval_pattern loc env (eval_expr loc env e) p) 459 | | Expr_Var(v) -> 460 | Env.getVar loc env v 461 | | Expr_Parens(e) -> 462 | let v = eval_expr loc env e in 463 | v 464 | | Expr_TApply(f, tes, es) -> 465 | (* First deal with &&, || and IMPLIES all of which only evaluate 466 | * their second argument if they need to 467 | *) 468 | if name_of_FIdent f = "and_bool" then begin 469 | (match (tes, es) with 470 | | ([], [x; y]) -> 471 | if to_bool loc (eval_expr loc env x) then 472 | eval_expr loc env y 473 | else 474 | from_bool false 475 | | _ -> 476 | raise (EvalError (loc, "malformed and_bool expression " 477 | ^ Utils.to_string (PP.pp_expr x))) 478 | ) 479 | end else if name_of_FIdent f = "or_bool" then begin 480 | (match (tes, es) with 481 | | ([], [x; y]) -> 482 | if to_bool loc (eval_expr loc env x) then 483 | from_bool true 484 | else 485 | eval_expr loc env y 486 | | _ -> 487 | raise (EvalError (loc, "malformed or_bool expression " 488 | ^ Utils.to_string (PP.pp_expr x))) 489 | ) 490 | end else if name_of_FIdent f = "implies_bool" then begin 491 | (match (tes, es) with 492 | | ([], [x; y]) -> 493 | if to_bool loc (eval_expr loc env x) then 494 | eval_expr loc env y 495 | else 496 | from_bool true 497 | | _ -> 498 | raise (EvalError (loc, "malformed implies_bool expression " 499 | ^ Utils.to_string (PP.pp_expr x))) 500 | ) 501 | end else begin 502 | let tvs = eval_exprs loc env tes in 503 | let vs = eval_exprs loc env es in 504 | eval_funcall loc env f tvs vs 505 | end 506 | | Expr_Tuple(es) -> 507 | let vs = List.map (eval_expr loc env) es in 508 | VTuple vs 509 | | Expr_Unop(op, e) -> 510 | raise (EvalError (loc, "unary operation should have been removed")) 511 | | Expr_Unknown(t) -> 512 | eval_unknown loc env t 513 | | Expr_ImpDef(t, Some(s)) -> 514 | Env.getImpdef loc env s 515 | | Expr_ImpDef(t, None) -> 516 | raise (EvalError (loc, "unnamed IMPLEMENTATION_DEFINED behavior")) 517 | | Expr_Array(a, i) -> 518 | let a' = eval_expr loc env a in 519 | let i' = eval_expr loc env i in 520 | get_array loc a' i' 521 | | Expr_LitInt(i) -> from_intLit i 522 | | Expr_LitHex(i) -> from_hexLit i 523 | | Expr_LitReal(r) -> from_realLit r 524 | | Expr_LitBits(b) -> from_bitsLit b 525 | | Expr_LitMask(b) -> from_maskLit b (* todo: masks should not be expressions *) 526 | | Expr_LitString(s) -> from_stringLit s 527 | ) 528 | 529 | (** Evaluate L-expression in write-mode (i.e., this is not a read-modify-write) *) 530 | and eval_lexpr (loc: l) (env: Env.t) (x: AST.lexpr) (r: value): unit = 531 | ( match x with 532 | | LExpr_Wildcard -> 533 | () 534 | | LExpr_Var(v) -> 535 | Env.setVar loc env v r 536 | | LExpr_Field(l, f) -> 537 | eval_lexpr_modify loc env l (fun prev -> set_field loc prev f r) 538 | | LExpr_Fields(l, fs) -> 539 | let rec set_fields (i: int) (fs: ident list) (prev: value): value = 540 | (match fs with 541 | | [] -> prev 542 | | (f::fs') -> 543 | let p = get_field loc prev f in (* read previous value to get width *) 544 | let w = Primops.prim_length_bits (Value.to_bits loc p) in 545 | let y = extract_bits' loc r i w in 546 | let v' = set_field loc prev f y in 547 | set_fields (i + w) fs' v' 548 | ) 549 | in 550 | eval_lexpr_modify loc env l (set_fields 0 fs) 551 | | LExpr_Slices(l, ss) -> 552 | let rec eval (o: value) (ss': AST.slice list) (prev: value): value = 553 | (match ss' with 554 | | [] -> prev 555 | | (s :: ss) -> 556 | let (i, w) = eval_slice loc env s in 557 | let v = extract_bits'' loc r o w in 558 | eval (eval_add_int loc o w) ss (insert_bits loc prev i w v) 559 | ) 560 | in 561 | eval_lexpr_modify loc env l (eval (VInt Z.zero) (List.rev ss)) 562 | | LExpr_BitTuple(ls) -> 563 | failwith "eval_lexpr: bittuple" 564 | | LExpr_Tuple(ls) -> 565 | let rs = of_tuple loc r in 566 | assert (List.length ls = List.length rs); 567 | List.iter2 (eval_lexpr loc env) ls rs 568 | | LExpr_Array(l, i) -> 569 | let i' = eval_expr loc env i in 570 | eval_lexpr_modify loc env l (fun prev -> set_array loc prev i' r) 571 | | LExpr_Write(setter, tes, es) -> 572 | let tvs = eval_exprs loc env tes in 573 | let vs = eval_exprs loc env es in 574 | eval_proccall loc env setter tvs (List.append vs [r]) 575 | | _ -> 576 | failwith ("eval_lexpr: "^ (pp_lexpr x)) 577 | ) 578 | 579 | (** Evaluate L-expression in read-modify-write mode. 580 | 581 | 1. The old value of the L-expression is read. 582 | 2. The function 'modify' is applied to the old value 583 | 3. The result is written back to the L-expression. 584 | *) 585 | and eval_lexpr_modify (loc: l) (env: Env.t) (x: AST.lexpr) (modify: value -> value): unit = 586 | (match x with 587 | | LExpr_Var(v) -> 588 | Env.setVar loc env v (modify (Env.getVar loc env v)) 589 | | LExpr_Field(l, f) -> 590 | let modify' (prev: value): value = 591 | let old = get_field loc prev f in 592 | set_field loc prev f (modify old) 593 | in 594 | eval_lexpr_modify loc env l modify' 595 | | LExpr_Array(l, i) -> 596 | let i' = eval_expr loc env i in 597 | let modify' (prev: value): value = 598 | let old = get_array loc prev i' in 599 | set_array loc prev i' (modify old) 600 | in 601 | eval_lexpr_modify loc env l modify' 602 | | LExpr_ReadWrite (getter, setter, tes, es) -> 603 | let tvs = eval_exprs loc env tes in 604 | let vs = eval_exprs loc env es in 605 | let old = eval_funcall loc env getter tvs vs in 606 | eval_proccall loc env setter tvs (List.append vs [modify old]) 607 | | _ -> 608 | failwith "eval_lexpr_modify" 609 | ) 610 | 611 | (** Evaluate list of statements *) 612 | and eval_stmts (env: Env.t) (xs: AST.stmt list): unit = 613 | Env.nest (fun env' -> List.iter (eval_stmt env') xs) env 614 | 615 | (** Evaluate statement *) 616 | and eval_stmt (env: Env.t) (x: AST.stmt): unit = 617 | (match x with 618 | | Stmt_VarDeclsNoInit(ty, vs, loc) -> 619 | List.iter (fun v -> Env.addLocalVar loc env v (mk_uninitialized loc env ty)) vs 620 | | Stmt_VarDecl(ty, v, i, loc) -> 621 | let i' = eval_expr loc env i in 622 | Env.addLocalVar loc env v i' 623 | | Stmt_ConstDecl(ty, v, i, loc) -> 624 | let i' = eval_expr loc env i in 625 | Env.addLocalConst loc env v i' 626 | | Stmt_Assign(l, r, loc) -> 627 | let r' = eval_expr loc env r in 628 | eval_lexpr loc env l r' 629 | | Stmt_TCall(f, tes, es, loc) -> 630 | let tvs = eval_exprs loc env tes in 631 | let vs = eval_exprs loc env es in 632 | eval_proccall loc env f tvs vs 633 | | Stmt_FunReturn(e, loc) -> 634 | let v = eval_expr loc env e in 635 | raise (Return (Some v)) 636 | | Stmt_ProcReturn(loc) -> 637 | raise (Return None) 638 | | Stmt_Assert(e, loc) -> 639 | if not (to_bool loc (eval_expr loc env e)) then 640 | raise (EvalError (loc, "assertion failure")) 641 | | Stmt_Unpred(loc) -> 642 | raise (Throw (loc, Exc_Unpredictable)) 643 | | Stmt_ConstrainedUnpred(loc) -> 644 | raise (Throw (loc, Exc_ConstrainedUnpredictable)) 645 | | Stmt_ImpDef(v, loc) -> 646 | raise (Throw (loc, Exc_ImpDefined (pprint_ident v))) 647 | | Stmt_Undefined(loc) -> 648 | raise (Throw (loc, Exc_Undefined)) 649 | | Stmt_ExceptionTaken(loc) -> 650 | raise (Throw (loc, Exc_ExceptionTaken)) 651 | | Stmt_Dep_Unpred(loc) -> 652 | raise (Throw (loc, Exc_Unpredictable)) 653 | | Stmt_Dep_ImpDef(s, loc) -> 654 | raise (Throw (loc, Exc_ImpDefined s)) 655 | | Stmt_Dep_Undefined(loc) -> 656 | raise (Throw (loc, Exc_Undefined)) 657 | | Stmt_See(e, loc) -> 658 | let s = to_string loc (eval_expr loc env e) in 659 | raise (Throw (loc, Exc_SEE s)) 660 | | Stmt_Throw(v, loc) -> 661 | let ex = to_exc loc (Env.getVar loc env v) in 662 | raise (Throw ex) 663 | | Stmt_If(c, t, els, e, loc) -> 664 | let rec eval css d = 665 | (match css with 666 | | [] -> eval_stmts env d 667 | | (S_Elsif_Cond(c, s) :: css') -> 668 | if to_bool loc (eval_expr loc env c) then 669 | eval_stmts env s 670 | else 671 | eval css' d 672 | ) 673 | in 674 | eval (S_Elsif_Cond(c, t) :: els) e 675 | | Stmt_Case(e, alts, odefault, loc) -> 676 | let rec eval v alts = 677 | (match alts with 678 | | [] -> 679 | (match odefault with 680 | | None -> raise (EvalError (loc, "unmatched case")) 681 | | Some s -> eval_stmts env s 682 | ) 683 | | (Alt_Alt(ps, oc, s) :: alts') -> 684 | if List.exists (eval_pattern loc env v) ps && from_option 685 | (map_option (to_bool loc) (map_option (eval_expr loc env) oc)) (fun _ -> true) then 686 | eval_stmts env s 687 | else 688 | eval v alts' 689 | ) 690 | in 691 | eval (eval_expr loc env e) alts 692 | | Stmt_For(v, start, dir, stop, b, loc) -> 693 | let start' = eval_expr loc env start in 694 | let stop' = eval_expr loc env stop in 695 | let rec eval i = 696 | let c = (match dir with 697 | | Direction_Up -> eval_leq loc i stop' 698 | | Direction_Down -> eval_leq loc stop' i 699 | ) in 700 | if c then begin 701 | Env.nest (fun env' -> 702 | Env.addLocalVar loc env' v i; 703 | eval_stmts env' b 704 | ) env; 705 | let i' = (match dir with 706 | | Direction_Up -> eval_add_int loc i (VInt Z.one) 707 | | Direction_Down -> eval_sub_int loc i (VInt Z.one) 708 | ) in 709 | eval i' 710 | end 711 | in 712 | eval start' 713 | 714 | | Stmt_While(c, b, loc) -> 715 | let rec eval _ = 716 | if to_bool loc (eval_expr loc env c) then 717 | eval_stmts env b; 718 | eval () 719 | in 720 | eval () 721 | | Stmt_Repeat(b, c, loc) -> 722 | let rec eval _ = 723 | eval_stmts env b; 724 | if to_bool loc (eval_expr loc env c) then 725 | eval () 726 | in 727 | eval () 728 | | Stmt_Try(tb, ev, catchers, odefault, loc) -> 729 | (try 730 | eval_stmts env tb 731 | with 732 | | Return v -> raise (Return v) 733 | | Throw (l, ex) -> 734 | Env.nest (fun env' -> 735 | let rec eval cs = 736 | (match cs with 737 | | [] -> 738 | (match odefault with 739 | | None -> raise (Throw (l, ex)) 740 | | Some s -> eval_stmts env' s 741 | ) 742 | | (Catcher_Guarded(c, b) :: cs') -> 743 | if to_bool loc (eval_expr loc env' c) then 744 | eval_stmts env' b 745 | else 746 | eval cs' 747 | ) 748 | in 749 | Env.addLocalVar loc env' ev (VExc (l, ex)); 750 | eval catchers 751 | ) env 752 | ) 753 | ) 754 | 755 | (** Evaluate call to function or procedure *) 756 | and eval_call (loc: l) (env: Env.t) (f: ident) (tvs: value list) (vs: value list): unit = 757 | (match eval_prim (name_of_FIdent f) tvs vs with 758 | | Some r -> 759 | if !trace_primop then begin 760 | Printf.printf "TRACE primop: %s " (pprint_ident f); 761 | List.iter (fun v -> Printf.printf " [%s]" (pp_value v)) tvs; 762 | List.iter (fun v -> Printf.printf " %s" (pp_value v)) vs; 763 | Printf.printf " --> %s\n" (pp_value r); 764 | end; 765 | raise (Return (Some r)) 766 | | None -> 767 | begin 768 | if !trace_funcall then begin 769 | Printf.printf "TRACE funcall: %s " (pprint_ident f); 770 | List.iter (fun v -> Printf.printf " [%s]" (pp_value v)) tvs; 771 | List.iter (fun v -> Printf.printf " %s" (pp_value v)) vs; 772 | Printf.printf "\n" 773 | end; 774 | let (targs, args, loc, b) = Env.getFun loc env f in 775 | assert (List.length targs = List.length tvs); 776 | assert (List.length args = List.length vs); 777 | Env.nestTop (fun env' -> 778 | List.iter2 (fun arg v -> Env.addLocalVar loc env' arg v) targs tvs; 779 | List.iter2 (fun arg v -> Env.addLocalVar loc env' arg v) args vs; 780 | eval_stmts env' b 781 | ) env 782 | end 783 | ) 784 | 785 | (** Evaluate call to function *) 786 | and eval_funcall (loc: l) (env: Env.t) (f: ident) (tvs: value list) (vs: value list): value = 787 | (try 788 | eval_call loc env f tvs vs; 789 | raise (EvalError (loc, "no return statement")) 790 | with 791 | | Return (Some v) -> v 792 | | Throw (l, ex) -> raise (Throw (l, ex)) 793 | ) 794 | 795 | (** Evaluate call to procedure *) 796 | and eval_proccall (loc: l) (env: Env.t) (f: ident) (tvs: value list) (vs: value list): unit = 797 | (try 798 | eval_call loc env f tvs vs 799 | with 800 | | Return None -> () 801 | | Return (Some (VTuple [])) -> () 802 | | Throw (l, ex) -> raise (Throw (l, ex)) 803 | ) 804 | 805 | (** Evaluate instruction encoding *) 806 | let eval_encoding (env: Env.t) (x: encoding) (op: value): bool = 807 | let Encoding_Block (nm, iset, fields, opcode, guard, unpreds, b, loc) = x in 808 | (* todo: consider checking iset *) 809 | (* Printf.printf "Checking opcode match %s == %s\n" (Utils.to_string (PP.pp_opcode_value opcode)) (pp_value op); *) 810 | let ok = (match opcode with 811 | | Opcode_Bits b -> eval_eq loc op (from_bitsLit b) 812 | | Opcode_Mask m -> eval_inmask loc op (from_maskLit m) 813 | ) in 814 | if ok then begin 815 | if !trace_instruction then Printf.printf "TRACE: instruction %s\n" (pprint_ident nm); 816 | List.iter (function (IField_Field (f, lo, wd)) -> 817 | let v = extract_bits' loc op lo wd in 818 | if !trace_instruction then Printf.printf " %s = %s\n" (pprint_ident f) (pp_value v); 819 | Env.addLocalVar loc env f v 820 | ) fields; 821 | if to_bool loc (eval_expr loc env guard) then begin 822 | List.iter (fun (i, b) -> 823 | if eval_eq loc (extract_bits' loc op i 1) (from_bitsLit b) then 824 | raise (Throw (loc, Exc_Unpredictable)) 825 | ) unpreds; 826 | List.iter (eval_stmt env) b; 827 | true 828 | end else begin 829 | false 830 | end 831 | end else begin 832 | false 833 | end 834 | 835 | (** Evaluate bitslice of instruction opcode *) 836 | let eval_decode_slice (loc: l) (env: Env.t) (x: decode_slice) (op: value): value = 837 | (match x with 838 | | DecoderSlice_Slice (lo, wd) -> extract_bits' loc op lo wd 839 | | DecoderSlice_FieldName f -> Env.getVar loc env f 840 | | DecoderSlice_Concat fs -> eval_concat loc (List.map (Env.getVar loc env) fs) 841 | ) 842 | 843 | (** Evaluate instruction decode pattern match *) 844 | let rec eval_decode_pattern (loc: AST.l) (x: decode_pattern) (op: value): bool = 845 | (match x with 846 | | DecoderPattern_Bits b -> eval_eq loc op (from_bitsLit b) 847 | | DecoderPattern_Mask m -> eval_inmask loc op (from_maskLit m) 848 | | DecoderPattern_Wildcard _ -> true 849 | | DecoderPattern_Not p -> not (eval_decode_pattern loc p op) 850 | ) 851 | 852 | (** Evaluate instruction decode case alternative *) 853 | let rec eval_decode_alt (loc: AST.l) (env: Env.t) (DecoderAlt_Alt (ps, b)) (vs: value list) (op: value): bool = 854 | if List.for_all2 (eval_decode_pattern loc) ps vs then 855 | (match b with 856 | | DecoderBody_UNPRED loc -> raise (Throw (loc, Exc_Unpredictable)) 857 | | DecoderBody_UNALLOC loc -> raise (Throw (loc, Exc_Undefined)) 858 | | DecoderBody_NOP loc -> true 859 | | DecoderBody_Encoding (enc, l) -> 860 | let (enc, opost, cond, exec) = Env.getInstruction loc env enc in 861 | if eval_encoding env enc op then begin 862 | (match opost with 863 | | Some post -> eval_stmts env post 864 | | None -> () 865 | ); 866 | (* todo: should evaluate ConditionHolds to decide whether to execute body *) 867 | List.iter (eval_stmt env) exec; 868 | true 869 | end else begin 870 | false 871 | end 872 | | DecoderBody_Decoder (fs, c, loc) -> 873 | let env = Env.empty in (* todo: this seems to share a single mutable object far too widely *) 874 | List.iter (function (IField_Field (f, lo, wd)) -> 875 | Env.addLocalVar loc env f (extract_bits' loc op lo wd) 876 | ) fs; 877 | eval_decode_case loc env c op; 878 | true 879 | ) 880 | else 881 | false 882 | 883 | (** Evaluate instruction decode case *) 884 | and eval_decode_case (loc: AST.l) (env: Env.t) (x: decode_case) (op: value): unit = 885 | (match x with 886 | | DecoderCase_Case (ss, alts, loc) -> 887 | let vs = List.map (fun s -> eval_decode_slice loc env s op) ss in 888 | let rec eval alts = 889 | (match alts with 890 | | (alt :: alts') -> 891 | if eval_decode_alt loc env alt vs op then 892 | () 893 | else 894 | eval alts' 895 | | [] -> 896 | raise (EvalError (loc, "unmatched decode pattern")) 897 | ) 898 | in 899 | eval alts 900 | ) 901 | 902 | 903 | (****************************************************************) 904 | (** {2 Creating environment from global declarations} *) 905 | (****************************************************************) 906 | 907 | (* todo: it would be better to make this a distinct value *) 908 | let eval_uninitialized (loc: l) (env: Env.t) (x: AST.ty): value = eval_unknown loc env x 909 | 910 | (** Construct environment from global declarations *) 911 | let build_evaluation_environment (ds: AST.declaration list): Env.t = begin 912 | if false then Printf.printf "Building environment from %d declarations\n" (List.length ds); 913 | let env = Env.empty in 914 | (* todo?: first pull out the constants/configs and evaluate all of them 915 | * lazily? 916 | *) 917 | List.iter (fun d -> 918 | (match d with 919 | | Decl_Record (v, fs, loc) -> 920 | Env.addRecord env v fs 921 | | Decl_Enum(qid, es, loc) -> 922 | let evs = if qid = Ident "boolean" then begin (* optimized special case *) 923 | [ (Ident "FALSE", VBool false); (Ident "TRUE", VBool true) ] 924 | end else begin 925 | List.mapi (fun i e -> (e, VEnum (e, i))) es; 926 | end 927 | in 928 | List.iter (fun (e, v) -> Env.addGlobalConst env e v) evs; 929 | Env.addEnum env qid (List.map (fun (e, v) -> v) evs) 930 | | Decl_Typedef (v, ty, loc) -> 931 | Env.addTypedef env v ty 932 | | Decl_Var(ty, v, loc) -> 933 | let init = eval_uninitialized loc env ty in 934 | Env.addGlobalVar env v init 935 | | Decl_Const(ty, v, i, loc) -> 936 | (* todo: constants need to be lazily evaluated or need to be 937 | * sorted by dependencies 938 | *) 939 | let init = eval_expr loc env i in 940 | Env.addGlobalConst env v init 941 | | Decl_FunDefn(rty, f, atys, body, loc) -> 942 | let tvs = Asl_utils.to_sorted_list (TC.fv_funtype (f, false, [], [], atys, rty)) in 943 | let args = List.map snd atys in 944 | Env.addFun loc env f (tvs, args, loc, body) 945 | | Decl_ProcDefn(f, atys, body, loc) -> 946 | let tvs = Asl_utils.to_sorted_list (Asl_utils.fv_args atys) in 947 | let args = List.map snd atys in 948 | Env.addFun loc env f (tvs, args, loc, body) 949 | | Decl_VarGetterDefn(ty, f, body, loc) -> 950 | let tvs = Asl_utils.to_sorted_list (Asl_utils.fv_type ty) in 951 | let args = [] in 952 | Env.addFun loc env f (tvs, args, loc, body) 953 | | Decl_ArrayGetterDefn(rty, f, atys, body, loc) -> 954 | let tvs = Asl_utils.to_sorted_list (TC.fv_funtype (f, true, [], [], atys, rty)) in 955 | let args = List.map snd atys in 956 | Env.addFun loc env f (tvs, args, loc, body) 957 | | Decl_VarSetterDefn(f, ty, v, body, loc) -> 958 | let tvs = Asl_utils.to_sorted_list (Asl_utils.fv_type ty) in 959 | let args = [v] in 960 | Env.addFun loc env f (tvs, args, loc, body) 961 | | Decl_ArraySetterDefn(f, atys, ty, v, body, loc) -> 962 | let tvs = Asl_utils.to_sorted_list (Asl_utils.IdentSet.union (Asl_utils.fv_sformals atys) (Asl_utils.fv_type ty)) in 963 | let name_of (x: AST.sformal): ident = 964 | (match x with 965 | | Formal_In (_, nm) -> nm 966 | | Formal_InOut (_, nm) -> nm 967 | ) 968 | in 969 | let args = List.map name_of atys in 970 | Env.addFun loc env f (tvs, List.append args [v], loc, body) 971 | | Decl_InstructionDefn(nm, encs, opost, conditional, exec, loc) -> 972 | (* Instructions are looked up by their encoding name *) 973 | List.iter (fun enc -> 974 | let Encoding_Block (nm, _, _, _, _, _, _, _) = enc in 975 | Env.addInstruction loc env nm (enc, opost, conditional, exec) 976 | ) encs 977 | | Decl_DecoderDefn(nm, case, loc) -> 978 | Env.addDecoder env nm case 979 | | Decl_NewMapDefn(rty, f, atys, body, loc) -> 980 | let tvs = Asl_utils.to_sorted_list (TC.fv_funtype (f, false, [], [], atys, rty)) in 981 | let args = List.map snd atys in 982 | Env.addFun loc env f (tvs, args, loc, body) 983 | (* 984 | | Decl_MapClause(f, atys, cond, body, loc) -> 985 | let tvs = Asl_utils.to_sorted_list (Asl_utils.fv_args atys) in 986 | let args' = List.map snd args in 987 | Env.addFun loc env f (tvs, args', loc, body) 988 | *) 989 | | Decl_NewEventDefn (f, atys, loc) -> 990 | let tvs = Asl_utils.to_sorted_list (Asl_utils.fv_args atys) in 991 | let args = List.map snd atys in 992 | Env.addFun loc env f (tvs, args, loc, []) 993 | | Decl_EventClause (f, body, loc) -> 994 | let (tvs, args, _, body0) = Env.getFun loc env f in 995 | Env.addFun loc env f (tvs, args, loc, List.append body body0) 996 | (* todo: when creating initial environment, should pass in a set of configuration 997 | * options that will override any default values given in definition 998 | *) 999 | | Decl_Config(ty, v, i, loc) -> 1000 | (* todo: config constants need to be lazily evaluated or need to be 1001 | * sorted by dependencies 1002 | *) 1003 | let init = eval_expr loc env i in 1004 | Env.addGlobalConst env v init 1005 | 1006 | (* The following declarations have no impact on execution *) 1007 | | Decl_BuiltinType (_, _) | Decl_Forward (_, _) 1008 | | Decl_BuiltinFunction (_, _, _, _) 1009 | | Decl_FunType (_, _, _, _) | Decl_ProcType (_, _, _) 1010 | | Decl_VarGetterType (_, _, _) | Decl_ArrayGetterType (_, _, _, _) 1011 | | Decl_VarSetterType (_, _, _, _) | Decl_ArraySetterType (_, _, _, _, _) 1012 | | Decl_Operator1 (_, _, _) 1013 | | Decl_Operator2 (_, _, _) 1014 | | Decl_MapClause (_, _, _, _, _) 1015 | -> () 1016 | ) 1017 | ) ds; 1018 | env 1019 | end 1020 | 1021 | 1022 | (**************************************************************** 1023 | * End 1024 | ****************************************************************) 1025 | -------------------------------------------------------------------------------- /lexer.mll: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * ASL lexer 3 | * 4 | * Copyright Arm Limited (c) 2017-2019 5 | * SPDX-Licence-Identifier: BSD-3-Clause 6 | ****************************************************************) 7 | 8 | { 9 | open Asl_parser (* The type token is defined in parser.mli *) 10 | open Asl_ast 11 | 12 | exception Eof 13 | 14 | let keywords : (string * Asl_parser.token) list = [ 15 | ("AND", AND); 16 | ("CONSTRAINED_UNPREDICTABLE", CONSTRAINED_UNDERSCORE_UNPREDICTABLE); 17 | ("DIV", DIV); 18 | ("EOR", EOR); 19 | ("IMPLEMENTATION_DEFINED", IMPLEMENTATION_UNDERSCORE_DEFINED); 20 | ("IN", IN); 21 | ("IFF", IFF); 22 | ("IMPLIES", IMPLIES); 23 | ("MOD", MOD); 24 | ("NOT", NOT); 25 | ("OR", OR); 26 | ("QUOT", QUOT); 27 | ("REM", REM); 28 | ("SEE", SEE); 29 | ("UNDEFINED", UNDEFINED); 30 | ("UNKNOWN", UNKNOWN); 31 | ("UNPREDICTABLE", UNPREDICTABLE); 32 | ("__ExceptionTaken", UNDERSCORE_UNDERSCORE_EXCEPTIONTAKEN); 33 | ("__NOP", UNDERSCORE_UNDERSCORE_NOP); 34 | ("__UNALLOCATED", UNDERSCORE_UNDERSCORE_UNALLOCATED); 35 | ("__UNPREDICTABLE", UNDERSCORE_UNDERSCORE_UNPREDICTABLE); 36 | ("__array", UNDERSCORE_UNDERSCORE_ARRAY); 37 | ("__builtin", UNDERSCORE_UNDERSCORE_BUILTIN); 38 | ("__conditional", UNDERSCORE_UNDERSCORE_CONDITIONAL); 39 | ("__config", UNDERSCORE_UNDERSCORE_CONFIG); 40 | ("__decode", UNDERSCORE_UNDERSCORE_DECODE); 41 | ("__encoding", UNDERSCORE_UNDERSCORE_ENCODING); 42 | ("__event", UNDERSCORE_UNDERSCORE_EVENT); 43 | ("__execute", UNDERSCORE_UNDERSCORE_EXECUTE); 44 | ("__field", UNDERSCORE_UNDERSCORE_FIELD); 45 | ("__function", UNDERSCORE_UNDERSCORE_FUNCTION); 46 | ("__guard", UNDERSCORE_UNDERSCORE_GUARD); 47 | ("__instruction", UNDERSCORE_UNDERSCORE_INSTRUCTION); 48 | ("__instruction_set", UNDERSCORE_UNDERSCORE_INSTRUCTION_UNDERSCORE_SET); 49 | ("__map", UNDERSCORE_UNDERSCORE_MAP); 50 | ("__newmap", UNDERSCORE_UNDERSCORE_NEWMAP); 51 | ("__newevent", UNDERSCORE_UNDERSCORE_NEWEVENT); 52 | ("__operator1", UNDERSCORE_UNDERSCORE_OPERATOR_ONE); 53 | ("__operator2", UNDERSCORE_UNDERSCORE_OPERATOR_TWO); 54 | ("__opcode", UNDERSCORE_UNDERSCORE_OPCODE); 55 | ("__postdecode", UNDERSCORE_UNDERSCORE_POSTDECODE); 56 | ("__readwrite", UNDERSCORE_UNDERSCORE_READWRITE); 57 | ("__register", UNDERSCORE_UNDERSCORE_REGISTER); 58 | ("__unpredictable_unless", UNDERSCORE_UNDERSCORE_UNPREDICTABLE_UNDERSCORE_UNLESS); 59 | ("__write", UNDERSCORE_UNDERSCORE_WRITE); 60 | ("array", ARRAY); 61 | ("assert", ASSERT); 62 | ("bits", BITS); 63 | ("case", CASE); 64 | ("catch", CATCH); 65 | ("constant", CONSTANT); 66 | ("do", DO); 67 | ("downto", DOWNTO); 68 | ("else", ELSE); 69 | ("elsif", ELSIF); 70 | ("enumeration", ENUMERATION); 71 | ("for", FOR); 72 | ("if", IF); 73 | ("is", IS); 74 | ("of", OF); 75 | ("otherwise", OTHERWISE); 76 | ("record", RECORD); 77 | ("repeat", REPEAT); 78 | ("return", RETURN); 79 | ("then", THEN); 80 | ("throw", THROW); 81 | ("to", TO); 82 | ("try", TRY); 83 | ("type", TYPE); 84 | ("typeof", TYPEOF); 85 | ("until", UNTIL); 86 | ("when", WHEN); 87 | ("while", WHILE); 88 | ] 89 | 90 | } 91 | 92 | rule token = parse 93 | (* whitespace and comments *) 94 | | ['\n'] { Lexing.new_line lexbuf; EOL1 } 95 | | [' ' '\t'] { token lexbuf } 96 | | '/' '/' [^'\n']* { token lexbuf } 97 | | '/' '*' { comment 1 lexbuf } 98 | 99 | (* numbers, strings and identifiers *) 100 | | '"' [^'"']* '"' as lxm { STRINGLIT(String.sub lxm 1 (String.length lxm - 2)) } 101 | | '\'' ['0' '1' ' ']* '\'' as lxm { BITSLIT(String.sub lxm 1 (String.length lxm - 2)) } 102 | | '\'' ['0' '1' 'x' ' ']* '\'' as lxm { MASKLIT(String.sub lxm 1 (String.length lxm - 2)) } 103 | | '0''x'['0'-'9' 'A' - 'F' 'a'-'f' '_']+ as lxm { HEXLIT(String.sub lxm 2 (String.length lxm - 2)) } 104 | | ['0'-'9']+ '.' ['0'-'9']+ as lxm { REALLIT(lxm) } 105 | | ['0'-'9']+ as lxm { INTLIT(lxm) } 106 | | ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* as lxm { 107 | ( match List.assoc_opt lxm keywords with 108 | | Some x -> x 109 | | None -> if isTypeIdent(lxm) then TYPEID(lxm) 110 | else if String.equal lxm "AArch32" then QUALIFIER(lxm) 111 | else if String.equal lxm "AArch64" then QUALIFIER(lxm) 112 | else ID(lxm) 113 | ) 114 | } 115 | 116 | (* delimiters *) 117 | | '!' { BANG } 118 | | '!' '=' { BANG_EQ } 119 | | '&' '&' { AMPERSAND_AMPERSAND } 120 | | '&' { AMPERSAND } 121 | | '(' { LPAREN } 122 | | ')' { RPAREN } 123 | | '*' { STAR } 124 | | '+' '+' { PLUS_PLUS } 125 | | '+' { PLUS } 126 | | '+' ':' { PLUS_COLON } 127 | | ',' { COMMA } 128 | | '-' { MINUS } 129 | | '.' { DOT } 130 | | '.' '.' { DOT_DOT } 131 | | '/' { SLASH } 132 | | ':' { COLON } 133 | | ';' { SEMICOLON } 134 | | '<' { LT } 135 | | '<' '<' { LT_LT } 136 | | '<' '=' { LT_EQ } 137 | | '=' { EQ } 138 | | '=' '=' { EQ_EQ } 139 | | '=' '>' { EQ_GT } 140 | | '>' { GT } 141 | | '>' '=' { GT_EQ } 142 | | '>' '>' { GT_GT } 143 | | '[' { LBRACK } 144 | | ']' { RBRACK } 145 | | '^' { CARET } 146 | | '{' { LBRACE } 147 | | '{' '{' { LBRACE_LBRACE } 148 | | '|' '|' { BAR_BAR } 149 | | '}' { RBRACE } 150 | | '}' '}' { RBRACE_RBRACE } 151 | | eof { raise Eof } 152 | | _ as c { Printf.printf "%s:%d Unrecognized character '%c'\n" 153 | lexbuf.lex_curr_p.pos_fname 154 | lexbuf.lex_curr_p.pos_lnum 155 | c; 156 | exit 0 } 157 | 158 | and comment depth = parse 159 | '/' '*' { comment (depth+1) lexbuf } 160 | | '*' '/' { if depth = 1 then token lexbuf else comment (depth-1) lexbuf } 161 | | '\n' { Lexing.new_line lexbuf; comment depth lexbuf } 162 | | _ { comment depth lexbuf } 163 | 164 | (**************************************************************** 165 | * End 166 | ****************************************************************) 167 | -------------------------------------------------------------------------------- /lexersupport.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * ASL lexer support 3 | * 4 | * Copyright Arm Limited (c) 2017-2019 5 | * SPDX-Licence-Identifier: BSD-3-Clause 6 | ****************************************************************) 7 | 8 | (** ASL lexer support *) 9 | 10 | open Lexer 11 | open Lexing 12 | open Asl_parser 13 | 14 | let string_of_token (t: Asl_parser.token): string = 15 | ( match t with 16 | | AMPERSAND -> "amp" 17 | | AMPERSAND_AMPERSAND -> "ampamp" 18 | | AND -> "and" 19 | | ARRAY -> "array" 20 | | ASSERT -> "assert" 21 | | BANG -> "bang" 22 | | BAR_BAR -> "barbar" 23 | | BITS -> "bits" 24 | | BITSLIT(x) -> "bin:"^x 25 | | UNDERSCORE_UNDERSCORE_ARRAY -> "__array" 26 | | UNDERSCORE_UNDERSCORE_BUILTIN -> "__builtin" 27 | | UNDERSCORE_UNDERSCORE_CONDITIONAL -> "__conditional" 28 | | UNDERSCORE_UNDERSCORE_CONFIG -> "__config" 29 | | UNDERSCORE_UNDERSCORE_DECODE -> "__decode" 30 | | UNDERSCORE_UNDERSCORE_ENCODING -> "__encoding" 31 | | UNDERSCORE_UNDERSCORE_EXCEPTIONTAKEN -> "__ExceptionTaken" 32 | | UNDERSCORE_UNDERSCORE_EXECUTE -> "__execute" 33 | | UNDERSCORE_UNDERSCORE_EVENT -> "__event" 34 | | UNDERSCORE_UNDERSCORE_FIELD -> "__field" 35 | | UNDERSCORE_UNDERSCORE_FUNCTION -> "__function" 36 | | UNDERSCORE_UNDERSCORE_GUARD -> "__guard" 37 | | UNDERSCORE_UNDERSCORE_INSTRUCTION -> "__instruction" 38 | | UNDERSCORE_UNDERSCORE_INSTRUCTION_UNDERSCORE_SET -> "__instruction_set" 39 | | UNDERSCORE_UNDERSCORE_MAP -> "__map" 40 | | UNDERSCORE_UNDERSCORE_NOP -> "__NOP" 41 | | UNDERSCORE_UNDERSCORE_NEWEVENT -> "__newevent" 42 | | UNDERSCORE_UNDERSCORE_NEWMAP -> "__newmap" 43 | | UNDERSCORE_UNDERSCORE_OPCODE -> "__opcode" 44 | | UNDERSCORE_UNDERSCORE_OPERATOR_ONE -> "__operator1" 45 | | UNDERSCORE_UNDERSCORE_OPERATOR_TWO -> "__operator2" 46 | | UNDERSCORE_UNDERSCORE_POSTDECODE -> "__postdecode" 47 | | UNDERSCORE_UNDERSCORE_READWRITE -> "__readwrite" 48 | | UNDERSCORE_UNDERSCORE_REGISTER -> "__register" 49 | | UNDERSCORE_UNDERSCORE_UNALLOCATED -> "__UNALLOCATED" 50 | | UNDERSCORE_UNDERSCORE_UNPREDICTABLE_UNDERSCORE_UNLESS -> "__unpredictable_unless" 51 | | UNDERSCORE_UNDERSCORE_UNPREDICTABLE -> "__UNPREDICTABLE" 52 | | UNDERSCORE_UNDERSCORE_WRITE -> "__write" 53 | | CARET -> "caret" 54 | | CASE -> "case" 55 | | CATCH -> "catch" 56 | | COLON -> "colon" 57 | | COMMA -> "comma" 58 | | CONSTANT -> "constant" 59 | | CONSTRAINED_UNDERSCORE_UNPREDICTABLE -> "constrained_unpredictable" 60 | | DEDENT -> "dedent" 61 | | DIV -> "div" 62 | | DO -> "do" 63 | | DOT -> "dot" 64 | | DOT_DOT -> "dotdot" 65 | | DOWNTO -> "downto" 66 | | ELSE -> "else" 67 | | ELSIF -> "elsif" 68 | | ENUMERATION -> "enum" 69 | | EOF -> "eof" 70 | | EOL1 -> "eol" 71 | | EOL2 () -> "eol" 72 | | EOR -> "eor" 73 | | EQ -> "eq" 74 | | EQ_EQ -> "eqeq" 75 | | EQ_GT -> "eqgt" 76 | | REALLIT(x) -> "real:"^x 77 | | FOR -> "for" 78 | | GT -> "gt" 79 | | GT_EQ -> "gteq" 80 | | GT_GT -> "gtgt" 81 | | HEXLIT(x) -> "hex:"^x 82 | | ID(x) -> "ident:"^x 83 | | IF -> "if" 84 | | IMPLEMENTATION_UNDERSCORE_DEFINED -> "impdef" 85 | | IN -> "in" 86 | | IFF -> "iff" 87 | | IMPLIES -> "implies" 88 | | INDENT -> "indent" 89 | | INTLIT(x) -> "int:" ^ x 90 | | IS -> "is" 91 | | LBRACE -> "lbrace" 92 | | LBRACE_LBRACE -> "{{" 93 | | LBRACK -> "lbrack" 94 | | LPAREN -> "lparen" 95 | | LT -> "lt" 96 | | LT_EQ -> "lteq" 97 | | LT_LT -> "ltlt" 98 | | MASKLIT(x) -> "mask:"^x 99 | | MINUS -> "minus" 100 | | MOD -> "mod" 101 | | BANG_EQ -> "neq" 102 | | NOT -> "not" 103 | | OF -> "of" 104 | | OR -> "or" 105 | | OTHERWISE -> "otherwise" 106 | | PLUS -> "plus" 107 | | PLUS_PLUS -> "plusplus" 108 | | PLUS_COLON -> "pluscolon" 109 | | QUALIFIER(x) -> "qualifier:"^x 110 | | QUOT -> "quot" 111 | | RBRACE -> "rbrace" 112 | | RBRACE_RBRACE -> "}}" 113 | | RBRACK -> "rbrack" 114 | | RECORD -> "record" 115 | | REM -> "rem" 116 | | REPEAT -> "repeat" 117 | | RETURN -> "return" 118 | | RPAREN -> "rparen" 119 | | SEE -> "see" 120 | | SEMICOLON -> "semi" 121 | | SLASH -> "slash" 122 | | STAR -> "star" 123 | | STRINGLIT(x) -> "string:" ^ x 124 | | THEN -> "then" 125 | | THROW -> "throw" 126 | | TYPEID(x) -> "tident:"^x 127 | | TO -> "to" 128 | | TRY -> "try" 129 | | TYPE -> "type" 130 | | TYPEOF -> "typeof" 131 | | UNDEFINED -> "undefined" 132 | | UNKNOWN -> "unknown" 133 | | UNPREDICTABLE -> "unpredictable" 134 | | UNTIL -> "until" 135 | | WHEN -> "when" 136 | | WHILE -> "while" 137 | ) 138 | 139 | let print_position outx lexbuf = 140 | let pos = lexbuf.lex_curr_p in 141 | Printf.fprintf outx "%s:%d:%d" pos.pos_fname 142 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 143 | 144 | let starters : Asl_parser.token list = [LPAREN; LBRACK; LBRACE; IF; ELSIF; WHILE] 145 | let enders : Asl_parser.token list = [RPAREN; RBRACK; RBRACE; THEN; DO] 146 | 147 | type offside_state = { 148 | mutable stack : int list; (* indentation history *) 149 | mutable parens : int; (* number of outstanding openers *) 150 | mutable newline: bool; (* processing newline *) 151 | mutable next : Asl_parser.token; (* next token *) 152 | } 153 | 154 | let offside_token (read: Lexing.lexbuf -> Asl_parser.token): (Lexing.lexbuf -> Asl_parser.token) = 155 | let state = { 156 | stack = [0]; 157 | parens = 0; 158 | newline = false; 159 | next = EOL1 160 | } in 161 | 162 | let pushStack (col: int): Asl_parser.token = begin 163 | state.stack <- col :: state.stack; 164 | INDENT 165 | end in 166 | 167 | let getToken (buf: Lexing.lexbuf): Asl_parser.token = begin 168 | let useToken _ : Asl_parser.token = begin 169 | let tok : Asl_parser.token = state.next in 170 | if List.mem tok starters then begin 171 | state.parens <- state.parens + 1 172 | end else if (state.parens > 0) && (List.mem tok enders) then begin 173 | state.parens <- state.parens - 1 174 | end; 175 | (try 176 | state.next <- read buf 177 | with Lexer.Eof -> state.next <- EOF); 178 | tok 179 | end in 180 | 181 | if state.parens > 0 then begin 182 | (* In parentheses: ignore EOL tokens *) 183 | while state.next = EOL1 do 184 | ignore (useToken()) 185 | done; 186 | useToken() 187 | end else if state.next = EOF then begin 188 | (* End of file: emit outstanding DEDENT tokens *) 189 | begin match state.stack with 190 | | [] 191 | | [_] -> 192 | EOF 193 | | (d::ds) -> 194 | state.stack <- ds; 195 | DEDENT 196 | end 197 | end else if state.next = EOL1 then begin 198 | while state.next = EOL1 do 199 | state.newline <- true; 200 | ignore(useToken()) 201 | done; 202 | EOL1 203 | end else begin 204 | if state.newline then begin 205 | let prev_col = List.hd state.stack in 206 | let pos = lexeme_start_p buf in 207 | let new_column = pos.pos_cnum - pos.pos_bol in 208 | if new_column > prev_col then begin 209 | state.newline <- false; 210 | pushStack new_column 211 | end else if new_column = prev_col then begin 212 | state.newline <- false; 213 | useToken() 214 | end else begin 215 | state.stack <- List.tl state.stack; 216 | let target_column = List.hd state.stack in 217 | (* state.newline <- false; *) 218 | state.newline <- new_column <> target_column; 219 | (* This gives spurious warnings when indentation is 220 | * decremented in two steps. 221 | * 222 | * if new_column < target_column then begin 223 | * Printf.printf "Warning: incorrect indentation %d: %d %d\n" 224 | * buf.lex_curr_p.pos_lnum 225 | * new_column target_column 226 | * end; 227 | *) 228 | DEDENT 229 | end 230 | end else begin 231 | useToken() 232 | end 233 | end 234 | end 235 | in 236 | getToken 237 | 238 | (**************************************************************** 239 | * End 240 | ****************************************************************) 241 | -------------------------------------------------------------------------------- /prelude.asl: -------------------------------------------------------------------------------- 1 | //////////////////////////////////////////////////////////////// 2 | // ASL standard prelude 3 | // 4 | // Copyright Arm Limited (c) 2017-2019 5 | // SPDX-Licence-Identifier: BSD-3-Clause 6 | //////////////////////////////////////////////////////////////// 7 | 8 | __builtin type integer; 9 | __builtin type real; 10 | __builtin type string; 11 | __builtin type __mask; // todo: should have a type parameter 12 | __builtin type __Exception; 13 | __builtin type __RAM; // todo: should have a type parameter 14 | 15 | type bit = bits(1); 16 | 17 | enumeration boolean { FALSE, TRUE }; 18 | enumeration signal { LOW, HIGH }; 19 | 20 | __builtin boolean eq_bool(boolean x, boolean y); 21 | __builtin boolean ne_bool(boolean x, boolean y); 22 | __builtin boolean not_bool(boolean x); 23 | __builtin boolean and_bool(boolean x, boolean y); 24 | __builtin boolean or_bool(boolean x, boolean y); 25 | __builtin boolean equiv_bool(boolean x, boolean y); 26 | __builtin boolean implies_bool(boolean x, boolean y); 27 | 28 | __builtin boolean eq_int(integer x, integer y); 29 | __builtin boolean ne_int(integer x, integer y); 30 | __builtin boolean gt_int(integer x, integer y); 31 | __builtin boolean ge_int(integer x, integer y); 32 | __builtin boolean le_int(integer x, integer y); 33 | __builtin boolean lt_int(integer x, integer y); 34 | __builtin boolean is_pow2_int(integer x); 35 | __builtin integer add_int(integer x, integer y); 36 | __builtin integer neg_int(integer x); 37 | __builtin integer sub_int(integer x, integer y); 38 | __builtin integer shl_int(integer x, integer y); 39 | __builtin integer shr_int(integer x, integer y); 40 | __builtin integer mul_int(integer x, integer y); 41 | __builtin integer zdiv_int(integer x, integer y); 42 | __builtin integer zrem_int(integer x, integer y); 43 | __builtin integer fdiv_int(integer x, integer y); 44 | __builtin integer frem_int(integer x, integer y); 45 | __builtin integer mod_pow2_int(integer x, integer y); 46 | __builtin integer align_int(integer x, integer y); 47 | __builtin integer pow2_int(integer y); 48 | 49 | __builtin real cvt_int_real(integer x); 50 | __builtin boolean eq_real(real x, real y); 51 | __builtin boolean ne_real(real x, real y); 52 | __builtin boolean le_real(real x, real y); 53 | __builtin boolean lt_real(real x, real y); 54 | __builtin boolean gt_real(real x, real y); 55 | __builtin boolean ge_real(real x, real y); 56 | __builtin real add_real(real x, real y); 57 | __builtin real neg_real(real x); 58 | __builtin real sub_real(real x, real y); 59 | __builtin real mul_real(real x, real y); 60 | __builtin real divide_real(real x, real y); 61 | __builtin real pow2_real(integer y); 62 | __builtin integer round_tozero_real(real x); 63 | __builtin integer round_down_real(real x); 64 | __builtin integer round_up_real(real x); 65 | __builtin real sqrt_real(real x); 66 | 67 | __builtin bits(N) cvt_int_bits(integer x, integer N); 68 | __builtin integer cvt_bits_sint(bits(N) x); 69 | __builtin integer cvt_bits_uint(bits(N) x); 70 | __builtin boolean in_mask(bits(N) x, __mask(N) y); 71 | __builtin boolean notin_mask(bits(N) x, __mask(N) y); 72 | __builtin boolean eq_bits(bits(N) x, bits(N) y); 73 | __builtin boolean ne_bits(bits(N) x, bits(N) y); 74 | __builtin bits(N) add_bits(bits(N) x, bits(N) y); 75 | __builtin bits(N) sub_bits(bits(N) x, bits(N) y); 76 | __builtin bits(N) mul_bits(bits(N) x, bits(N) y); 77 | __builtin integer frem_bits_int(bits(N) x, integer y); 78 | __builtin bits(N) and_bits(bits(N) x, bits(N) y); 79 | __builtin bits(N) or_bits(bits(N) x, bits(N) y); 80 | __builtin bits(N) eor_bits(bits(N) x, bits(N) y); 81 | __builtin bits(N) not_bits(bits(N) x); 82 | __builtin bits(N) zeros_bits(); 83 | __builtin bits(N) ones_bits(); 84 | 85 | bits(N) add_bits_int(bits(N) x, integer y) 86 | return add_bits(x, cvt_int_bits(y, N)); 87 | 88 | bits(N) sub_bits_int(bits(N) x, integer y) 89 | return sub_bits(x, cvt_int_bits(y, N)); 90 | 91 | __operator2 + = add_int, add_real, add_bits, add_bits_int; 92 | __operator2 - = sub_int, sub_real, sub_bits, sub_bits_int; 93 | __operator1 - = neg_int, neg_real; 94 | __operator2 * = mul_int, mul_real, mul_bits; 95 | __operator2 / = divide_real; 96 | 97 | __builtin bits(M*N) replicate_bits(bits(M) x, integer N); 98 | __builtin bits(M+N) append_bits(bits(M) x, bits(N) y); 99 | 100 | __builtin boolean is_cunpred_exc(__Exception ex); 101 | __builtin boolean is_exctaken_exc(__Exception ex); 102 | __builtin boolean is_impdef_exc(__Exception ex); 103 | __builtin boolean is_see_exc(__Exception ex); 104 | __builtin boolean is_undefined_exc(__Exception ex); 105 | __builtin boolean is_unpred_exc(__Exception ex); 106 | 107 | __builtin string cvt_int_hexstr(integer x); 108 | __builtin string cvt_int_decstr(integer x); 109 | __builtin string cvt_bool_str(boolean x); 110 | __builtin string cvt_bits_str(integer N, bits(N) x); 111 | __builtin string cvt_real_str(real x); 112 | __builtin string append_str_str(string x, string y); 113 | __builtin boolean eq_str(string x, string y); 114 | __builtin boolean ne_str(string x, string y); 115 | __builtin () print_str(string x); 116 | __builtin () print_char(integer x); 117 | 118 | __builtin () asl_pragma(string x); 119 | 120 | __builtin integer asl_file_open(string name, string mode); 121 | __builtin integer asl_file_write(integer fd, string data); 122 | __builtin integer asl_file_getc(integer fd); 123 | 124 | __builtin () ram_init(integer A, integer N, __RAM(A) ram, bits(8*N) val); 125 | __builtin bits(8*N) ram_read(integer A, integer N, __RAM(A) ram, bits(A) address); 126 | __builtin () ram_write(integer A, integer N, __RAM(A) ram, bits(A) address, bits(8*N) val); 127 | 128 | __InitRAM(integer A, integer N, __RAM(A) ram, bits(8*N) val) 129 | ram_init(A, N, ram, val); 130 | 131 | bits(8*N) __ReadRAM(integer A, integer N, __RAM(A) ram, bits(A) address) 132 | return ram_read(A, N, ram, address); 133 | 134 | __WriteRAM(integer A, integer N, __RAM(A) ram, bits(A) address, bits(8*N) val) 135 | ram_write(A, N, ram, address, val); 136 | 137 | __builtin () trace_memory_write(integer N, bits(A) address, bits(8*N) val); 138 | __builtin () trace_memory_read(integer N, bits(A) address, bits(8*N) val); 139 | __builtin () trace_event(string event); 140 | 141 | __tarmacEvent(string event) 142 | trace_event(event); 143 | 144 | __builtin () sleep_request(); 145 | __builtin () wakeup_request(); 146 | __builtin () program_end(); 147 | 148 | __builtin () decodeInstr_A64(bits(32) instr); 149 | __builtin () decodeInstr_A32(bits(32) instr); 150 | __builtin () decodeInstr_T32(bits(32) instr); 151 | __builtin () decodeInstr_T16(bits(16) instr); 152 | 153 | print(bits(N) x) 154 | print_str(cvt_bits_str(N, x)); 155 | 156 | print(string x) 157 | print_str(x); 158 | 159 | println() 160 | print_char(10); 161 | 162 | println(string x) 163 | print_str(x); 164 | print_char(10); 165 | 166 | putchar(integer c) 167 | print_char(c); 168 | 169 | __abort() 170 | program_end(); 171 | 172 | __operator1 ! = not_bool; 173 | __operator2 && = and_bool; 174 | __operator2 || = or_bool; 175 | __operator2 IFF = equiv_bool; 176 | __operator2 IMPLIES = implies_bool; 177 | 178 | // omit since they are auto-generated 179 | // __operator2 == = eq_bool; 180 | // __operator2 != = ne_bool; 181 | 182 | __operator2 == = eq_int, eq_real, eq_bits, eq_str, in_mask; 183 | __operator2 != = ne_int, ne_real, ne_bits, ne_str, notin_mask; 184 | __operator2 <= = le_int, le_real; 185 | __operator2 >= = ge_int, ge_real; 186 | __operator2 < = lt_int, lt_real; 187 | __operator2 > = gt_int, gt_real; 188 | 189 | integer shift_left_int(integer x, integer y) 190 | return if y >= 0 then shl_int(x, y) else shr_int(x, -y); 191 | 192 | integer shift_right_int(integer x, integer y) 193 | return if y >= 0 then shr_int(x, y) else shl_int(x, -y); 194 | 195 | __operator2 << = shift_left_int; 196 | __operator2 >> = shift_right_int; 197 | 198 | integer pow_int_int(integer x, integer y) 199 | if x == 2 then 200 | return pow2_int(y); // optimized case 201 | else 202 | assert y >= 0; 203 | integer result = 1; 204 | for i = 1 to y 205 | result = result * x; 206 | return result; 207 | 208 | real pow_real_int(real x, integer y) 209 | assert x == 2.0; 210 | return pow2_real(y); 211 | 212 | __operator2 ^ = pow_int_int, pow_real_int; 213 | 214 | real Real(integer x) 215 | return cvt_int_real(x); 216 | 217 | integer frem_bits_int(bits(N) x, integer y) 218 | assert y > 0; 219 | return frem_int(cvt_bits_uint(x), y); 220 | 221 | // Division: round to zero 222 | __operator2 QUOT = zdiv_int; 223 | __operator2 REM = zrem_int; 224 | 225 | // Division: round to -infinity (floor) 226 | __operator2 DIV = fdiv_int; 227 | __operator2 MOD = frem_int, frem_bits_int; 228 | 229 | __operator2 AND = and_bits; 230 | __operator2 OR = or_bits; 231 | __operator2 EOR = eor_bits; 232 | __operator1 NOT = not_bits; 233 | 234 | string HexStr(integer x) 235 | return cvt_int_hexstr(x); 236 | 237 | string DecStr(integer x) 238 | return cvt_int_decstr(x); 239 | 240 | string append_str_bool(string x, boolean y) 241 | return append_str_str(x, cvt_bool_str(y)); 242 | 243 | string append_bool_str(boolean x, string y) 244 | return append_str_str(cvt_bool_str(x), y); 245 | 246 | string append_str_bits(string x, bits(N) y) 247 | return append_str_str(x, cvt_bits_str(N, y)); 248 | 249 | string append_bits_str(bits(N) x, string y) 250 | return append_str_str(cvt_bits_str(N, x), y); 251 | 252 | string append_str_real(string x, real y) 253 | return append_str_str(x, cvt_real_str(y)); 254 | 255 | string append_real_str(real x, string y) 256 | return append_str_str(cvt_real_str(x), y); 257 | 258 | string append_str_int(string x, integer y) 259 | return append_str_str(x, DecStr(y)); 260 | 261 | string append_int_str(integer x, string y) 262 | return append_str_str(DecStr(x), y); 263 | 264 | __operator2 ++ = append_str_str; 265 | __operator2 ++ = append_str_bool, append_bool_str; 266 | __operator2 ++ = append_str_real, append_real_str; 267 | __operator2 ++ = append_str_bits, append_bits_str; 268 | __operator2 ++ = append_str_int, append_int_str; 269 | 270 | __operator2 : = append_bits; 271 | 272 | bits(M*N) Replicate(bits(M) x, integer N) 273 | return replicate_bits(x, N); 274 | 275 | bits(N) Replicate(bits(M) x) 276 | assert N MOD M == 0; 277 | return replicate_bits(x, N DIV M); 278 | 279 | bits(N) Zeros(integer N) 280 | return zeros_bits(); 281 | 282 | bits(N) Ones(integer N) 283 | return ones_bits(); 284 | 285 | bits(N) Zeros() 286 | return zeros_bits(); 287 | 288 | bits(N) Ones() 289 | return ones_bits(); 290 | 291 | boolean IsOnes(bits(N) x) 292 | return x == Ones(); 293 | 294 | boolean IsZero(bits(N) x) 295 | return x == Zeros(); 296 | 297 | bits(N) SignExtend(bits(M) x, integer N) 298 | assert N >= M; 299 | return Replicate(x[M-1], N-M) : x; 300 | 301 | bits(N) ZeroExtend(bits(M) x, integer N) 302 | assert N >= M; 303 | return Zeros(N-M) : x; 304 | 305 | // The existence of SignExtend and ZeroExtend makes the 306 | // typesystem considerably more complex because we cannot 307 | // determine the value of 'N' just from the types of the 308 | // arguments. 309 | bits(N) SignExtend(bits(M) x) 310 | return SignExtend(x, N); 311 | 312 | bits(N) ZeroExtend(bits(M) x) 313 | return ZeroExtend(x, N); 314 | 315 | real Sqrt(real x) 316 | return sqrt_real(x); 317 | 318 | integer RoundTowardsZero(real x) 319 | return round_tozero_real(x); 320 | 321 | integer RoundDown(real x) 322 | return round_down_real(x); 323 | 324 | integer RoundUp(real x) 325 | return round_up_real(x); 326 | 327 | boolean IsUNDEFINED(__Exception x) 328 | return is_undefined_exc(x); 329 | 330 | boolean IsUNPREDICTABLE(__Exception x) 331 | return is_unpred_exc(x); 332 | 333 | boolean IsSEE(__Exception x) 334 | return is_see_exc(x); 335 | 336 | boolean IsExceptionTaken(__Exception x) 337 | return is_exctaken_exc(x); 338 | 339 | integer UInt(integer N, bits(N) x) 340 | return cvt_bits_uint(x); 341 | 342 | integer UInt(bits(N) x) 343 | return cvt_bits_uint(x); 344 | 345 | integer SInt(integer N, bits(N) x) 346 | return cvt_bits_sint(x); 347 | 348 | integer SInt(bits(N) x) 349 | return cvt_bits_sint(x); 350 | 351 | bits(N) Align(bits(N) x, integer y) 352 | return align_int(cvt_bits_uint(x), y)[N-1:0]; 353 | 354 | integer Align(integer x, integer y) 355 | return align_int(x, y); 356 | 357 | 358 | //////////////////////////////////////////////////////////////// 359 | // End 360 | //////////////////////////////////////////////////////////////// 361 | -------------------------------------------------------------------------------- /primops.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * ASL primitive types and operations 3 | * 4 | * Copyright Arm Limited (c) 2017-2019 5 | * SPDX-Licence-Identifier: BSD-3-Clause 6 | ****************************************************************) 7 | 8 | (** ASL primitive types and operations *) 9 | 10 | module AST = Asl_ast 11 | 12 | (****************************************************************) 13 | (** {2 Boolean primops} *) 14 | (****************************************************************) 15 | 16 | let prim_eq_bool (x: bool) (y: bool): bool = x = y 17 | let prim_ne_bool (x: bool) (y: bool): bool = x <> y 18 | let prim_and_bool (x: bool) (y: bool): bool = x && y 19 | let prim_or_bool (x: bool) (y: bool): bool = x || y 20 | let prim_equiv_bool (x: bool) (y: bool): bool = x = y 21 | let prim_not_bool (x: bool): bool = not x 22 | 23 | 24 | (****************************************************************) 25 | (** {2 Integer primops} *) 26 | (****************************************************************) 27 | 28 | type bigint = Z.t 29 | 30 | let prim_eq_int (x: bigint) (y: bigint): bool = Z.equal x y 31 | let prim_ne_int (x: bigint) (y: bigint): bool = not (Z.equal x y) 32 | let prim_le_int (x: bigint) (y: bigint): bool = Z.leq x y 33 | let prim_lt_int (x: bigint) (y: bigint): bool = Z.lt x y 34 | let prim_ge_int (x: bigint) (y: bigint): bool = Z.geq x y 35 | let prim_gt_int (x: bigint) (y: bigint): bool = Z.gt x y 36 | let prim_is_pow2_int (x: bigint): bool = Z.equal (Z.logand x (Z.sub x Z.one)) Z.zero 37 | let prim_neg_int (x: bigint): bigint = Z.neg x 38 | let prim_add_int (x: bigint) (y: bigint): bigint = Z.add x y 39 | let prim_sub_int (x: bigint) (y: bigint): bigint = Z.sub x y 40 | let prim_shl_int (x: bigint) (y: bigint): bigint = Z.shift_left x (Z.to_int y) 41 | let prim_shr_int (x: bigint) (y: bigint): bigint = Z.shift_right x (Z.to_int y) 42 | let prim_mul_int (x: bigint) (y: bigint): bigint = Z.mul x y 43 | 44 | let prim_zdiv_int (x: bigint) (y: bigint): bigint = Z.div x y 45 | let prim_zrem_int (x: bigint) (y: bigint): bigint = Z.rem x y 46 | let prim_fdiv_int (x: bigint) (y: bigint): bigint = Z.fdiv x y 47 | let prim_frem_int (x: bigint) (y: bigint): bigint = Z.sub x (Z.mul y (Z.fdiv x y)) 48 | let prim_mod_pow2_int (x: bigint) (y: bigint): bigint = 49 | let mask = Z.sub (Z.shift_left Z.one (Z.to_int y)) Z.one in 50 | Z.logand x mask 51 | let prim_align_int (x: bigint) (y: bigint): bigint = 52 | let y' = Z.to_int y in 53 | (* todo: not very efficient *) 54 | Z.shift_left (Z.shift_right_trunc x y') y' 55 | 56 | let prim_pow2_int (x: bigint): bigint = Z.shift_left Z.one (Z.to_int x) 57 | 58 | let prim_pow_int_int (x: bigint) (y: bigint): bigint = 59 | let y' = Z.to_int y in 60 | assert (y' >= 0); 61 | Z.pow x y' 62 | 63 | 64 | (****************************************************************) 65 | (** {2 Real primops} *) 66 | (****************************************************************) 67 | 68 | type real = Q.t 69 | 70 | let prim_cvt_int_real (x: bigint): real = Q.of_bigint x 71 | let prim_eq_real (x: real) (y: real): bool = Q.equal x y 72 | let prim_ne_real (x: real) (y: real): bool = not (Q.equal x y) 73 | let prim_le_real (x: real) (y: real): bool = Q.leq x y 74 | let prim_lt_real (x: real) (y: real): bool = Q.lt x y 75 | let prim_ge_real (x: real) (y: real): bool = Q.geq x y 76 | let prim_gt_real (x: real) (y: real): bool = Q.gt x y 77 | let prim_neg_real (x: real): real = Q.neg x 78 | let prim_add_real (x: real) (y: real): real = Q.add x y 79 | let prim_sub_real (x: real) (y: real): real = Q.sub x y 80 | let prim_mul_real (x: real) (y: real): real = Q.mul x y 81 | let prim_div_real (x: real) (y: real): real = Q.div x y 82 | 83 | let prim_pow2_real (x: bigint): real = 84 | let x' = Z.to_int x in 85 | if x' >= 0 then Q.mul_2exp Q.one x' else Q.div_2exp Q.one (-x') 86 | 87 | let prim_round_tozero_real (x: real): bigint = Q.to_bigint x 88 | 89 | let prim_round_down_real (x: real): bigint = 90 | if Q.sign x >= 0 then begin 91 | Q.to_bigint x 92 | end else if Z.equal Z.one (Q.den x) then begin (* exact int *) 93 | Q.to_bigint x 94 | end else begin 95 | Z.sub Z.one (Q.to_bigint x) 96 | end 97 | 98 | let prim_round_up_real (x: real): bigint = 99 | if Q.sign x <= 0 then begin 100 | Q.to_bigint x 101 | end else if Z.equal Z.one (Q.den x) then begin (* exact int *) 102 | Q.to_bigint x 103 | end else begin 104 | Z.add Z.one (Q.to_bigint x) 105 | end 106 | 107 | let prim_sqrt_real (x: real): real = failwith "prim_sqrt_real" 108 | 109 | 110 | (****************************************************************) 111 | (** {2 Bitvector primops} *) 112 | (****************************************************************) 113 | 114 | (** Invariants: 115 | - the bigint part of a bitvector is positive 116 | - the bigint part of an N-bit bitvector is less than 2^N 117 | *) 118 | 119 | type bitvector = { n: int; v: Z.t } 120 | 121 | let empty_bits = { n = 0; v = Z.zero } 122 | 123 | (* primary way of creating bitvector satisfying invariants *) 124 | let mkBits (n: int) (v: bigint): bitvector = ( 125 | assert (n >= 0); 126 | if n = 0 then (* workaround: ZArith library doesn't like zero-length extracts *) 127 | { n; v = Z.zero } 128 | else 129 | { n; v = Z.extract v 0 n } 130 | ) 131 | 132 | (* utility function for use in implementing binary operators 133 | * that checks that size of left operand and of right operand were the same 134 | *) 135 | let mkBits2 (n1: int) (n2: int) (v: bigint): bitvector = ( 136 | assert (n1 = n2); 137 | assert (n1 >= 0); 138 | if n1 = 0 then (* workaround: ZArith library doesn't like zero-length extracts *) 139 | { n = n1; v = Z.zero } 140 | else 141 | { n = n1; v = Z.extract v 0 n1 } 142 | ) 143 | 144 | let prim_length_bits (x: bitvector): int = x.n 145 | 146 | let prim_cvt_int_bits (n: bigint) (i: bigint): bitvector = ( 147 | assert (Z.geq n Z.zero); 148 | let n' = Z.to_int n in 149 | { n = n'; v = Z.extract i 0 n' } 150 | ) 151 | 152 | let prim_cvt_bits_sint (x: bitvector): bigint = Z.signed_extract x.v 0 x.n 153 | let prim_cvt_bits_uint (x: bitvector): bigint = Z.extract x.v 0 x.n 154 | 155 | let prim_eq_bits (x: bitvector) (y: bitvector): bool = assert (x.n = y.n); Z.equal x.v y.v 156 | let prim_ne_bits (x: bitvector) (y: bitvector): bool = assert (x.n = y.n); not (Z.equal x.v y.v) 157 | let prim_add_bits (x: bitvector) (y: bitvector): bitvector = mkBits2 x.n y.n (Z.add x.v y.v) 158 | let prim_sub_bits (x: bitvector) (y: bitvector): bitvector = mkBits2 x.n y.n (Z.sub x.v y.v) 159 | 160 | (* Note that because mul_bits produces the same size result as its inputs, the 161 | * result is the same whether you consider bits to be signed or unsigned 162 | *) 163 | let prim_mul_bits (x: bitvector) (y: bitvector): bitvector = mkBits2 x.n y.n (Z.mul x.v y.v) 164 | 165 | let prim_and_bits (x: bitvector) (y: bitvector): bitvector = mkBits x.n (Z.logand x.v y.v) 166 | let prim_or_bits (x: bitvector) (y: bitvector): bitvector = mkBits x.n (Z.logor x.v y.v) 167 | let prim_eor_bits (x: bitvector) (y: bitvector): bitvector = mkBits x.n (Z.logxor x.v y.v) 168 | let prim_not_bits (x: bitvector): bitvector = mkBits x.n (Z.lognot x.v) 169 | 170 | let prim_zeros_bits (x: bigint): bitvector = mkBits (Z.to_int x) Z.zero 171 | let prim_ones_bits (x: bigint): bitvector = mkBits (Z.to_int x) Z.minus_one 172 | let prim_append_bits (x: bitvector) (y: bitvector): bitvector = mkBits (x.n+y.n) (Z.logor (Z.shift_left x.v y.n) y.v) 173 | 174 | let prim_replicate_bits (x: bitvector) (y: bigint): bitvector = 175 | (* Tail recursive helper to calculate "x : ... : x : r" with c copies of x *) 176 | let rec power x c r = 177 | if c = 0 then r 178 | else 179 | let r' = if (c land 1) = 0 then r else prim_append_bits x r in 180 | power (prim_append_bits x x) (c / 2) r' 181 | in 182 | assert (Z.sign y >= 0); 183 | power x (Z.to_int y) empty_bits 184 | 185 | let prim_extract (x: bitvector) (i: bigint) (w: bigint): bitvector = 186 | let i' = Z.to_int i in 187 | let w' = Z.to_int w in 188 | assert (0 <= i'); 189 | assert (0 <= w'); 190 | assert (i' + w' <= x.n); 191 | mkBits w' (Z.extract x.v i' w') 192 | 193 | let prim_extract_int (x: Z.t) (i: bigint) (w: bigint): bitvector = 194 | let i' = Z.to_int i in 195 | let w' = Z.to_int w in 196 | assert (0 <= i'); 197 | assert (0 <= w'); 198 | mkBits w' (Z.extract x i' w') 199 | 200 | let prim_insert (x: bitvector) (i: bigint) (w: bigint) (y: bitvector): bitvector = 201 | let i' = Z.to_int i in 202 | let w' = Z.to_int w in 203 | assert (0 <= i'); 204 | assert (0 <= w'); 205 | assert (i' + w' <= x.n); 206 | assert (w' = y.n); 207 | let msk = (Z.sub (Z.shift_left Z.one (i'+w')) (Z.shift_left Z.one i')) in 208 | let nmsk = Z.lognot msk in 209 | let y' = Z.shift_left (Z.extract y.v 0 w') i' in 210 | mkBits x.n (Z.logor (Z.logand nmsk x.v) (Z.logand msk y')) 211 | 212 | 213 | (****************************************************************) 214 | (** {2 Mask primops} *) 215 | (****************************************************************) 216 | 217 | type mask = { n: int; v: Z.t; m: Z.t } 218 | 219 | let mkMask (n: int) (v: Z.t) (m: Z.t): mask = 220 | assert (Z.equal v (Z.logand v m)); 221 | { n; v; m } 222 | 223 | let prim_in_mask (x: bitvector) (m: mask): bool = 224 | Z.equal (Z.logand x.v m.m) m.v 225 | 226 | let prim_notin_mask (x: bitvector) (m: mask): bool = 227 | not (prim_in_mask x m) 228 | 229 | 230 | (****************************************************************) 231 | (** {2 Exception primops} *) 232 | (****************************************************************) 233 | 234 | type exc = 235 | | Exc_ConstrainedUnpredictable 236 | | Exc_ExceptionTaken 237 | | Exc_ImpDefined of string 238 | | Exc_SEE of string 239 | | Exc_Undefined 240 | | Exc_Unpredictable 241 | 242 | let prim_is_cunpred_exc (x: exc): bool = (match x with Exc_ConstrainedUnpredictable -> true | _ -> false) 243 | let prim_is_exctaken_exc (x: exc): bool = (match x with Exc_ExceptionTaken -> true | _ -> false) 244 | let prim_is_impdef_exc (x: exc): bool = (match x with Exc_ImpDefined _ -> true | _ -> false) 245 | let prim_is_see_exc (x: exc): bool = (match x with Exc_SEE _ -> true | _ -> false) 246 | let prim_is_undefined_exc (x: exc): bool = (match x with Exc_Undefined -> true | _ -> false) 247 | let prim_is_unpred_exc (x: exc): bool = (match x with Exc_Unpredictable -> true | _ -> false) 248 | 249 | 250 | (****************************************************************) 251 | (** {2 String primops} *) 252 | (****************************************************************) 253 | 254 | let prim_eq_str (x: string) (y: string): bool = x = y 255 | let prim_ne_str (x: string) (y: string): bool = x <> y 256 | let prim_append_str (x: string) (y: string): string = x ^ y 257 | let prim_cvt_int_hexstr (x: bigint): string = Z.format "%x" x 258 | let prim_cvt_int_decstr (x: bigint): string = Z.to_string x 259 | let prim_cvt_bool_str (x: bool): string = if x then "TRUE" else "FALSE" 260 | 261 | let prim_cvt_bits_str (n: bigint) (x: bitvector): string = 262 | if Z.equal n Z.zero then begin 263 | "''" 264 | end else begin 265 | let s = Z.format "%0b" x.v in 266 | let pad = String.make (Z.to_int n - String.length s) '0' in 267 | Z.to_string n ^ "'" ^ pad ^ s ^ "'" 268 | end 269 | 270 | let prim_cvt_real_str (x: real): string = 271 | let r = Q.to_string x in 272 | if String.contains r '/' then r else r ^ "/1" 273 | 274 | 275 | (****************************************************************) 276 | (** {2 Immutable Array type} *) 277 | (****************************************************************) 278 | 279 | module Index = struct 280 | type t = int 281 | let compare x y = Stdlib.compare x y 282 | end 283 | 284 | module ImmutableArray = Map.Make(Index) 285 | 286 | let prim_empty_array: 'a ImmutableArray.t = 287 | ImmutableArray.empty 288 | 289 | let prim_read_array (x: 'a ImmutableArray.t) (i: int) (default: 'a): 'a = 290 | (match ImmutableArray.find_opt i x with 291 | | Some r -> r 292 | | None -> default 293 | ) 294 | 295 | let prim_write_array (x: 'a ImmutableArray.t) (i: int) (v: 'a): 'a ImmutableArray.t = 296 | ImmutableArray.add i v x 297 | 298 | 299 | (****************************************************************) 300 | (** {2 Mutable RAM type} *) 301 | (****************************************************************) 302 | 303 | (** RAM is implemented as a paged data structure and pages are 304 | allocated on demand and initialized with a specified default 305 | value. 306 | *) 307 | 308 | module Pages = struct 309 | include Map.Make(struct 310 | type t = bigint 311 | let compare = Z.compare 312 | end) 313 | end 314 | 315 | type ram = { 316 | mutable contents: Bytes.t Pages.t; 317 | mutable default: char 318 | } 319 | 320 | let logPageSize = 16 321 | let pageSize = 1 lsl logPageSize 322 | let pageMask = Z.of_int (pageSize - 1) 323 | 324 | let pageIndexOfAddr (a: bigint): bigint = Z.shift_right a logPageSize 325 | let pageOffsetOfAddr (a: bigint): bigint = Z.logand a pageMask 326 | 327 | let init_ram (d: char): ram = 328 | { contents = Pages.empty; default = d } 329 | 330 | let clear_ram (mem: ram) (d: char): unit = 331 | mem.contents <- Pages.empty; 332 | mem.default <- d 333 | 334 | let readByte_ram (mem: ram) (addr: bigint): char = 335 | let index = pageIndexOfAddr addr in 336 | let offset = pageOffsetOfAddr addr in 337 | (match Pages.find_opt index mem.contents with 338 | | Some bs -> Bytes.get bs (Z.to_int offset) 339 | | None -> mem.default 340 | ) 341 | 342 | let writeByte_ram (mem: ram) (addr: bigint) (v: char): unit = 343 | let index = pageIndexOfAddr addr in 344 | let offset = pageOffsetOfAddr addr in 345 | let bs = (match Pages.find_opt index mem.contents with 346 | | Some bs -> 347 | bs 348 | | None -> 349 | let bs = Bytes.make pageSize mem.default in 350 | mem.contents <- Pages.add index bs mem.contents; 351 | bs 352 | ) in 353 | Bytes.set bs (Z.to_int offset) v 354 | 355 | let prim_init_ram (asz: bigint) (dsz: bigint) (mem: ram) (init: bitvector): unit = 356 | clear_ram mem (char_of_int (Z.to_int init.v)) 357 | 358 | let prim_read_ram (asz: bigint) (dsz: bigint) (mem: ram) (addr: bigint): bitvector = 359 | let r = ref Z.zero in 360 | let rec read (i: int): unit = 361 | if i < (Z.to_int dsz) then 362 | let b = readByte_ram mem (Z.add addr (Z.of_int i)) in 363 | r := Z.logor (Z.shift_left (Z.of_int (int_of_char b)) (8 * i)) !r; 364 | read (i+1) 365 | in 366 | read 0; 367 | mkBits (8 * (Z.to_int dsz)) !r 368 | 369 | let prim_write_ram (asz: bigint) (dsz: bigint) (mem: ram) (addr: bigint) (v: bitvector): unit = 370 | let rec write (i: int): unit = 371 | if i < (Z.to_int dsz) then 372 | let b = char_of_int (Z.to_int (Z.extract v.v (i*8) 8)) in 373 | writeByte_ram mem (Z.add addr (Z.of_int i)) b; 374 | write (i+1) 375 | in 376 | write 0 377 | 378 | 379 | (****************************************************************) 380 | (** {2 File primops} *) 381 | (****************************************************************) 382 | 383 | (** These are not part of the official ASL language but they are 384 | useful when implementing the infrastructure needed in simulators. 385 | *) 386 | 387 | let prim_open_file (name: string) (mode: string): bigint = 388 | failwith "open_file" 389 | 390 | let prim_write_file (fd: bigint) (data: string): unit = 391 | failwith "write_file" 392 | 393 | let prim_getc_file (fd: bigint): bigint = 394 | failwith "getc_file" 395 | 396 | let prim_print_str (data: string): unit = 397 | Printf.printf "%s" data 398 | 399 | let prim_print_char (data: bigint): unit = 400 | Printf.printf "%c" (char_of_int (Z.to_int data)) 401 | 402 | 403 | (****************************************************************) 404 | (** {2 Trace primops} *) 405 | (****************************************************************) 406 | 407 | (** These are not part of the official ASL language but they are 408 | useful when implementing the infrastructure needed in simulators. 409 | *) 410 | 411 | let prim_trace_memory_read (asz: bigint) (dsz: bigint) (mem: ram) (addr: bigint) (v: bitvector): unit = () 412 | let prim_trace_memory_write (asz: bigint) (dsz: bigint) (mem: ram) (addr: bigint) (v: bitvector): unit = () 413 | let prim_trace_event (msg: string): unit = () 414 | 415 | 416 | (**************************************************************** 417 | * End 418 | ****************************************************************) 419 | -------------------------------------------------------------------------------- /testlexer.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * ASL lexer test harness 3 | * 4 | * Copyright Arm Limited (c) 2017-2019 5 | * SPDX-Licence-Identifier: BSD-3-Clause 6 | ****************************************************************) 7 | 8 | (** ASL lexer test harness *) 9 | 10 | open Asl_ast 11 | 12 | module Lexer = Lexer 13 | module Parser = Asl_parser 14 | module TC = Tcheck 15 | module PP = Asl_parser_pp 16 | open Lexersupport 17 | open Lexing 18 | 19 | let opt_filenames : string list ref = ref [] 20 | let opt_output : string ref = ref "asl.out" (* not used at present *) 21 | let opt_print_version = ref false 22 | 23 | let options = Arg.align ([ 24 | ( "-o", Arg.Set_string opt_output, " Set output file" ); 25 | ( "-v", Arg.Set opt_print_version, " Print version"); 26 | ] ) 27 | 28 | let version = "ASL Lexer 0.0" 29 | let usage_msg = 30 | ( version 31 | ^ "\nusage: testlexer ... \n" 32 | ) 33 | 34 | let _ = 35 | Arg.parse options 36 | (fun s -> opt_filenames := (!opt_filenames) @ [s]) 37 | usage_msg 38 | 39 | let _ = 40 | List.iter (fun filename -> 41 | let inchan = open_in filename in 42 | let lexbuf = Lexing.from_channel inchan in 43 | 44 | lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; 45 | 46 | (* Apply offside rule to raw token stream *) 47 | let lexer = offside_token Lexer.token in 48 | 49 | let eof = ref false in 50 | while not !eof do 51 | let tok = lexer lexbuf in 52 | let curr = lexbuf.Lexing.lex_curr_p in 53 | let line = curr.Lexing.pos_lnum in 54 | let cnum = curr.Lexing.pos_cnum - curr.Lexing.pos_bol in 55 | Printf.printf "Token line %d column %d: %s\n" line cnum (string_of_token tok); 56 | eof := tok = EOF 57 | done; 58 | 59 | Printf.printf "End of file\n" 60 | ) !opt_filenames 61 | 62 | (**************************************************************** 63 | * End 64 | ****************************************************************) 65 | -------------------------------------------------------------------------------- /utils.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * Generic utility functions 3 | * 4 | * Copyright Arm Limited (c) 2017-2019 5 | * SPDX-Licence-Identifier: BSD-3-Clause 6 | ****************************************************************) 7 | 8 | (** Generic utility functions *) 9 | 10 | (**************************************************************** 11 | * Pretty-printer related 12 | ****************************************************************) 13 | 14 | let to_string (d: PPrintEngine.document): string = 15 | let buf = Buffer.create 100 in 16 | PPrintEngine.ToBuffer.compact buf d; 17 | Buffer.contents buf 18 | 19 | 20 | (**************************************************************** 21 | * List related 22 | ****************************************************************) 23 | 24 | let nub (xs: 'a list): 'a list = 25 | let rec nub_aux seen xs = (match xs with 26 | | [] -> seen 27 | | (y::ys) -> if List.mem y seen then nub_aux seen ys else nub_aux (y::seen) ys 28 | ) in 29 | nub_aux [] xs 30 | 31 | let zip_list (xs: 'a list) (ys: 'b list): ('a * 'b) list = 32 | List.map2 (fun x y -> (x, y)) xs ys 33 | 34 | let zipWithIndex (f: 'a -> int -> 'b) (xs: 'a list): 'b list = 35 | let rec aux i xs = (match xs with 36 | | [] -> [] 37 | | (y::ys) -> f y i :: aux (i+1) ys 38 | ) in 39 | aux 0 xs 40 | 41 | (**************************************************************** 42 | * Option related 43 | ****************************************************************) 44 | 45 | let isNone (ox : 'a option): bool = 46 | (match ox with 47 | | None -> true 48 | | Some _ -> false 49 | ) 50 | 51 | let map_option (f: 'a -> 'b) (ox: 'a option): 'b option = 52 | (match ox with 53 | | None -> None 54 | | Some x -> Some (f x) 55 | ) 56 | 57 | let get_option (ox: 'a option): 'a = 58 | (match ox with 59 | | None -> raise Not_found 60 | | Some x -> x 61 | ) 62 | 63 | let from_option (ox: 'a option) (d: unit -> 'a): 'a = 64 | (match ox with 65 | | None -> d() 66 | | Some x -> x 67 | ) 68 | 69 | let bind_option (ox: 'a option) (f: 'a -> 'b option): 'b option = 70 | (match ox with 71 | | None -> None 72 | | Some x -> f x 73 | ) 74 | 75 | let orelse_option (ox: 'a option) (f: unit -> 'a option): 'a option = 76 | (match ox with 77 | | None -> f() 78 | | Some x -> ox 79 | ) 80 | 81 | let rec concat_option (oss: (('a list) option) list): ('a list) option = 82 | (match oss with 83 | | [] -> Some [] 84 | | None::_ -> None 85 | | (Some xs)::xss -> map_option (List.append xs) (concat_option xss) 86 | ) 87 | 88 | (* extract all non-None elements from a list *) 89 | let flatten_option (os: ('a option) list): 'a list = 90 | let rec aux r os = (match os with 91 | | [] -> List.rev r 92 | | Some o :: os' -> aux (o::r) os' 93 | | None :: os' -> aux r os' 94 | ) 95 | in 96 | aux [] os 97 | 98 | (* extract all non-None elements from a list *) 99 | let flatmap_option (f: 'a -> 'b option) (xs: 'a list): 'b list = 100 | let rec aux r xs = (match xs with 101 | | [] -> List.rev r 102 | | x :: xs' -> 103 | (match f x with 104 | | Some b -> aux (b::r) xs' 105 | | None -> aux r xs' 106 | ) 107 | ) 108 | in 109 | aux [] xs 110 | 111 | (* todo: give this a better name *) 112 | let flatten_map_option (f: 'a -> 'b option) (xs: 'a list): 'b list option = 113 | let rec aux r xs = (match xs with 114 | | [] -> Some (List.rev r) 115 | | x :: xs' -> 116 | (match f x with 117 | | Some b -> aux (b::r) xs' 118 | | None -> None 119 | ) 120 | ) 121 | in 122 | aux [] xs 123 | 124 | (* find first non-None result from function 'f' on list 'xs' *) 125 | let rec first_option (f: 'a -> 'b option) (xs: 'a list): 'b option = 126 | (match xs with 127 | | [] -> None 128 | | x :: xs' -> 129 | (match f x with 130 | | Some b -> Some b 131 | | None -> first_option f xs' 132 | ) 133 | ) 134 | 135 | 136 | (**************************************************************** 137 | * String related 138 | ****************************************************************) 139 | 140 | (** Test whether 'x' starts with (is prefixed by) 'y' *) 141 | let startswith (x: string) (y: string): bool = 142 | let lx = String.length x in 143 | let ly = String.length y in 144 | if lx < ly then begin 145 | false 146 | end else begin 147 | let head = String.sub x 0 ly in 148 | String.equal head y 149 | end 150 | 151 | (** Test whether 'x' ends with (is suffixed by) 'y' *) 152 | let endswith (x: string) (y: string): bool = 153 | let lx = String.length x in 154 | let ly = String.length y in 155 | if lx < ly then begin 156 | false 157 | end else begin 158 | let tail = String.sub x (lx - ly) ly in 159 | String.equal tail y 160 | end 161 | 162 | (** Drop first n characters from string *) 163 | let stringDrop (n: int) (s: string): string = 164 | let l = String.length s in 165 | if n > l then begin 166 | "" 167 | end else begin 168 | String.sub s n (l-n) 169 | end 170 | 171 | (**************************************************************** 172 | * End 173 | ****************************************************************) 174 | -------------------------------------------------------------------------------- /value.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * ASL interpreter values 3 | * 4 | * Copyright Arm Limited (c) 2017-2019 5 | * SPDX-Licence-Identifier: BSD-3-Clause 6 | ****************************************************************) 7 | 8 | (** ASL interpreter values *) 9 | 10 | open Primops 11 | 12 | module AST = Asl_ast 13 | open Asl_utils 14 | 15 | (****************************************************************) 16 | (** {2 Values} *) 17 | (****************************************************************) 18 | 19 | (** This union type is for use in an interpreter *) 20 | 21 | type value = 22 | | VBool of bool (* optimised special case of VEnum *) 23 | | VEnum of (AST.ident * int) 24 | | VInt of bigint 25 | | VReal of real 26 | | VBits of bitvector 27 | | VMask of mask 28 | | VString of string 29 | | VExc of (AST.l * exc) 30 | | VTuple of (value list) 31 | | VRecord of (value Bindings.t) 32 | | VArray of (value ImmutableArray.t * value) 33 | | VRAM of ram 34 | | VUninitialized (* initial value of scalars with no explicit initialization *) 35 | 36 | 37 | (****************************************************************) 38 | (** {2 Exceptions thrown by interpreter} *) 39 | (****************************************************************) 40 | 41 | exception Return of value option 42 | exception EvalError of (AST.l * string) 43 | exception Throw of (AST.l * exc) 44 | 45 | 46 | (****************************************************************) 47 | (** {2 Printer for values} *) 48 | (****************************************************************) 49 | 50 | let rec pp_value (x: value): string = 51 | (match x with 52 | | VBool b -> prim_cvt_bool_str b 53 | | VEnum (e, _) -> AST.pprint_ident e 54 | | VInt i -> prim_cvt_int_decstr i 55 | | VReal r -> prim_cvt_real_str r 56 | | VBits b -> prim_cvt_bits_str (Z.of_int b.n) b 57 | | VMask m -> "todo: mask" 58 | | VString s -> "\"" ^ s ^ "\"" 59 | | VExc (loc, exc) -> 60 | let msg = (match exc with 61 | | Exc_ConstrainedUnpredictable -> "ConstrainedUnpredictable" 62 | | Exc_ExceptionTaken -> "ExceptionTaken" 63 | | Exc_ImpDefined s -> "ImpDefined" ^ s 64 | | Exc_SEE s -> "SEE" ^ s 65 | | Exc_Undefined -> "Undefined" 66 | | Exc_Unpredictable -> "Unpredictable" 67 | ) in 68 | "Exception " ^ msg ^ " at " ^ Asl_ast.pp_loc loc 69 | | VTuple vs -> "(" ^ String.concat ", " (List.map pp_value vs) ^ ")" 70 | | VRecord fs -> 71 | let fs' = List.map (fun (f, v) -> "."^ AST.pprint_ident f ^" = "^ pp_value v) (Bindings.bindings fs) 72 | in 73 | "{" ^ String.concat ", " fs' ^ "}" 74 | | VArray (a, _) -> 75 | let vs = List.map (fun (i, v) -> string_of_int i ^":"^ pp_value v) (ImmutableArray.bindings a) in 76 | "[" ^ String.concat ", " vs ^ "]" 77 | | VRAM _ -> "RAM" 78 | | VUninitialized -> "UNINITIALIZED" 79 | ) 80 | 81 | 82 | (****************************************************************) 83 | (** {2 Functions on values} *) 84 | (****************************************************************) 85 | 86 | let from_bool (x: bool): value = VBool x 87 | 88 | let to_bool (loc: AST.l) (x: value): bool = 89 | (match x with 90 | | VBool b -> b 91 | | _ -> raise (EvalError (loc, "boolean expected")) 92 | ) 93 | 94 | let to_integer (loc: AST.l) (x: value): bigint = 95 | (match x with 96 | | VInt i -> i 97 | | _ -> raise (EvalError (loc, "integer expected")) 98 | ) 99 | 100 | (* todo: this should raise an exception if out of range *) 101 | let to_int (loc: AST.l) (x: value): int = 102 | (match x with 103 | | VInt i -> Z.to_int i 104 | | _ -> raise (EvalError (loc, "integer expected")) 105 | ) 106 | 107 | let to_bits (loc: AST.l) (x: value): bitvector = 108 | (match x with 109 | | VBits b -> b 110 | | _ -> raise (EvalError (loc, "bits expected")) 111 | ) 112 | 113 | let to_mask (loc: AST.l) (x: value): mask = 114 | (match x with 115 | | VMask m -> m 116 | | _ -> raise (EvalError (loc, "mask expected")) 117 | ) 118 | 119 | let to_string (loc: AST.l) (x: value): string = 120 | (match x with 121 | | VString s -> s 122 | | _ -> raise (EvalError (loc, "string expected")) 123 | ) 124 | 125 | let to_exc (loc: AST.l) (x: value): (AST.l * exc) = 126 | (match x with 127 | | VExc e -> e 128 | | _ -> raise (EvalError (loc, "exception expected")) 129 | ) 130 | 131 | let to_tuple (xs: value list): value = VTuple xs 132 | 133 | let of_tuple (loc: AST.l) (x: value): value list = 134 | (match x with 135 | | VTuple xs -> xs 136 | | _ -> raise (EvalError (loc, "tuple expected")) 137 | ) 138 | 139 | let mkrecord (fs: (AST.ident * value) list): value = 140 | VRecord (mk_bindings fs) 141 | 142 | let get_field (loc: AST.l) (x: value) (f: AST.ident): value = 143 | (match x with 144 | | VRecord fs -> Bindings.find f fs 145 | | _ -> raise (EvalError (loc, "record expected")) 146 | ) 147 | 148 | let set_field (loc: AST.l) (x: value) (f: AST.ident) (v: value): value = 149 | (match x with 150 | | VRecord fs -> VRecord (Bindings.add f v fs) 151 | | _ -> raise (EvalError (loc, "record expected")) 152 | ) 153 | 154 | let empty_array (d: value): value = 155 | VArray (prim_empty_array, d) 156 | 157 | let get_array (loc: AST.l) (a: value) (i: value): value = 158 | (match (a, i) with 159 | | (VArray (x, d), VInt i') -> prim_read_array x (Z.to_int i') d 160 | | (VArray (x, d), VEnum i') -> prim_read_array x (snd i') d 161 | | (VArray (x, d), _) -> raise (EvalError (loc, "array index expected")) 162 | | _ -> raise (EvalError (loc, "array expected")) 163 | ) 164 | 165 | let set_array (loc: AST.l) (a: value) (i: value) (v: value): value = 166 | (match (a, i) with 167 | | (VArray (x, d), VInt i') -> VArray (prim_write_array x (Z.to_int i') v, d) 168 | | (VArray (x, d), VEnum i') -> VArray (prim_write_array x (snd i') v, d) 169 | | (VArray (x, d), _) -> raise (EvalError (loc, "array index expected")) 170 | | _ -> raise (EvalError (loc, "array expected")) 171 | ) 172 | 173 | (** Delete all characters matching 'c' from string 'x' *) 174 | let drop_chars (x: string) (c: char): string = 175 | (* First calculate final length *) 176 | let len = ref 0 in 177 | String.iter (fun t -> if t <> c then len := !len + 1) x; 178 | 179 | (* search for next character not matching c *) 180 | let i = ref 0 in 181 | let rec next_char (_: int): char = 182 | let r = String.get x !i in 183 | i := !i + 1; 184 | if r = c then next_char 0 else r 185 | in 186 | 187 | (* create result *) 188 | String.init !len next_char 189 | 190 | 191 | let from_intLit (x: AST.intLit): value = VInt (Z.of_string x) 192 | let from_hexLit (x: AST.hexLit): value = VInt (Z.of_string_base 16 (drop_chars x '_')) 193 | 194 | let from_realLit (x: AST.realLit): value = 195 | let pt = String.index x '.' in 196 | let fracsz = String.length x - pt - 1 in 197 | let intpart = String.sub x 0 pt in 198 | let frac = String.sub x (pt+1) fracsz in 199 | let numerator = Z.of_string (intpart ^ frac) in 200 | let denominator = Z.pow (Z.of_int 10) fracsz in 201 | VReal (Q.make numerator denominator) 202 | 203 | let from_bitsLit (x: AST.bitsLit): value = 204 | let x' = drop_chars x ' ' in 205 | VBits (mkBits (String.length x') (Z.of_string_base 2 x')) 206 | 207 | let from_maskLit (x: AST.maskLit): value = 208 | let x' = drop_chars x ' ' in 209 | let n = String.length x' in 210 | let v = String.map (function 'x' -> '0' | c -> c) x' in 211 | let m = String.map (function 'x' -> '0' | c -> '1') x' in 212 | VMask (mkMask n (Z.of_string_base 2 v) (Z.of_string_base 2 m)) 213 | 214 | let from_stringLit (x: string): value = VString x 215 | 216 | 217 | (****************************************************************) 218 | (** {2 Primop dispatch on values} *) 219 | (****************************************************************) 220 | 221 | (** Returns None iff function does not exist or arguments have wrong type *) 222 | 223 | let eval_prim (f: string) (tvs: value list) (vs: value list): value option = 224 | ( match (f, tvs, vs) with 225 | | ("eq_enum", [ ], [VEnum x; VEnum y ]) -> Some (VBool (snd x = snd y)) 226 | | ("ne_enum", [ ], [VEnum x; VEnum y ]) -> Some (VBool (snd x <> snd y)) 227 | | ("eq_bool", [ ], [VBool x; VBool y ]) -> Some (VBool (prim_eq_bool x y)) 228 | | ("ne_bool", [ ], [VBool x; VBool y ]) -> Some (VBool (prim_ne_bool x y)) 229 | | ("equiv_bool", [ ], [VBool x; VBool y ]) -> Some (VBool (prim_equiv_bool x y)) 230 | | ("not_bool", [ ], [VBool x ]) -> Some (VBool (prim_not_bool x)) 231 | | ("eq_int", [ ], [VInt x; VInt y ]) -> Some (VBool (prim_eq_int x y)) 232 | | ("ne_int", [ ], [VInt x; VInt y ]) -> Some (VBool (prim_ne_int x y)) 233 | | ("le_int", [ ], [VInt x; VInt y ]) -> Some (VBool (prim_le_int x y)) 234 | | ("lt_int", [ ], [VInt x; VInt y ]) -> Some (VBool (prim_lt_int x y)) 235 | | ("ge_int", [ ], [VInt x; VInt y ]) -> Some (VBool (prim_ge_int x y)) 236 | | ("gt_int", [ ], [VInt x; VInt y ]) -> Some (VBool (prim_gt_int x y)) 237 | | ("is_pow2_int", [ ], [VInt x ]) -> Some (VBool (prim_is_pow2_int x)) 238 | | ("neg_int", [ ], [VInt x ]) -> Some (VInt (prim_neg_int x)) 239 | | ("add_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_add_int x y)) 240 | | ("sub_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_sub_int x y)) 241 | | ("shl_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_shl_int x y)) 242 | | ("shr_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_shr_int x y)) 243 | | ("mul_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_mul_int x y)) 244 | | ("zdiv_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_zdiv_int x y)) 245 | | ("zrem_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_zrem_int x y)) 246 | | ("fdiv_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_fdiv_int x y)) 247 | | ("frem_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_frem_int x y)) 248 | | ("mod_pow2_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_mod_pow2_int x y)) 249 | | ("align_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_align_int x y)) 250 | | ("pow2_int", [ ], [VInt x ]) -> Some (VInt (prim_pow2_int x)) 251 | | ("pow_int_int", [ ], [VInt x; VInt y ]) -> Some (VInt (prim_pow_int_int x y)) 252 | | ("cvt_int_real", [ ], [VInt x ]) -> Some (VReal (prim_cvt_int_real x)) 253 | | ("eq_real", [ ], [VReal x; VReal y ]) -> Some (VBool (prim_eq_real x y)) 254 | | ("ne_real", [ ], [VReal x; VReal y ]) -> Some (VBool (prim_ne_real x y)) 255 | | ("le_real", [ ], [VReal x; VReal y ]) -> Some (VBool (prim_le_real x y)) 256 | | ("lt_real", [ ], [VReal x; VReal y ]) -> Some (VBool (prim_lt_real x y)) 257 | | ("ge_real", [ ], [VReal x; VReal y ]) -> Some (VBool (prim_ge_real x y)) 258 | | ("gt_real", [ ], [VReal x; VReal y ]) -> Some (VBool (prim_gt_real x y)) 259 | | ("add_real", [ ], [VReal x; VReal y ]) -> Some (VReal (prim_add_real x y)) 260 | | ("neg_real", [ ], [VReal x ]) -> Some (VReal (prim_neg_real x)) 261 | | ("sub_real", [ ], [VReal x; VReal y ]) -> Some (VReal (prim_sub_real x y)) 262 | | ("mul_real", [ ], [VReal x; VReal y ]) -> Some (VReal (prim_mul_real x y)) 263 | | ("divide_real", [ ], [VReal x; VReal y ]) -> Some (VReal (prim_div_real x y)) 264 | | ("pow2_real", [ ], [VInt x ]) -> Some (VReal (prim_pow2_real x)) 265 | | ("round_tozero_real", [ ], [VReal x ]) -> Some (VInt (prim_round_tozero_real x)) 266 | | ("round_down_real", [ ], [VReal x ]) -> Some (VInt (prim_round_down_real x)) 267 | | ("round_up_real", [ ], [VReal x ]) -> Some (VInt (prim_round_up_real x)) 268 | | ("sqrt_real", [ ], [VReal x; VReal y ]) -> Some (VReal (prim_sqrt_real x)) 269 | | ("cvt_int_bits", [_ ], [VInt x; VInt n ]) -> Some (VBits (prim_cvt_int_bits n x)) 270 | | ("cvt_bits_sint", [VInt n], [VBits x ]) -> Some (VInt (prim_cvt_bits_sint x)) 271 | | ("cvt_bits_uint", [VInt n], [VBits x ]) -> Some (VInt (prim_cvt_bits_uint x)) 272 | | ("in_mask", [VInt n], [VBits x; VMask y ]) -> Some (VBool (prim_in_mask x y)) 273 | | ("notin_mask", [VInt n], [VBits x; VMask y ]) -> Some (VBool (prim_notin_mask x y)) 274 | | ("eq_bits", [VInt n], [VBits x; VBits y ]) -> Some (VBool (prim_eq_bits x y)) 275 | | ("ne_bits", [VInt n], [VBits x; VBits y ]) -> Some (VBool (prim_ne_bits x y)) 276 | | ("add_bits", [VInt n], [VBits x; VBits y ]) -> Some (VBits (prim_add_bits x y)) 277 | | ("sub_bits", [VInt n], [VBits x; VBits y ]) -> Some (VBits (prim_sub_bits x y)) 278 | | ("mul_bits", [VInt n], [VBits x; VBits y ]) -> Some (VBits (prim_mul_bits x y)) 279 | | ("and_bits", [VInt n], [VBits x; VBits y ]) -> Some (VBits (prim_and_bits x y)) 280 | | ("or_bits", [VInt n], [VBits x; VBits y ]) -> Some (VBits (prim_or_bits x y)) 281 | | ("eor_bits", [VInt n], [VBits x; VBits y ]) -> Some (VBits (prim_eor_bits x y)) 282 | | ("not_bits", [VInt n], [VBits x ]) -> Some (VBits (prim_not_bits x)) 283 | | ("zeros_bits", [VInt n], [ ]) -> Some (VBits (prim_zeros_bits n)) 284 | | ("ones_bits", [VInt n], [ ]) -> Some (VBits (prim_ones_bits n)) 285 | | ("replicate_bits", [_; _ ], [VBits x; VInt y ]) -> Some (VBits (prim_replicate_bits x y)) 286 | | ("append_bits", [VInt m; VInt n], [VBits x; VBits y]) -> Some (VBits (prim_append_bits x y)) 287 | | ("eq_str", [ ], [VString x; VString y]) -> Some (VBool (prim_eq_str x y)) 288 | | ("ne_str", [ ], [VString x; VString y]) -> Some (VBool (prim_ne_str x y)) 289 | | ("append_str_str", [ ], [VString x; VString y]) -> Some (VString (prim_append_str x y)) 290 | | ("cvt_int_hexstr", [ ], [VInt x ]) -> Some (VString (prim_cvt_int_hexstr x)) 291 | | ("cvt_int_decstr", [ ], [VInt x ]) -> Some (VString (prim_cvt_int_decstr x)) 292 | | ("cvt_bool_str", [ ], [VBool x ]) -> Some (VString (prim_cvt_bool_str x)) 293 | | ("cvt_bits_str", [_ ], [VInt n; VBits x ]) -> Some (VString (prim_cvt_bits_str n x)) 294 | | ("cvt_real_str", [ ], [VReal x ]) -> Some (VString (prim_cvt_real_str x)) 295 | | ("is_cunpred_exc", [ ], [VExc (_, ex) ]) -> Some (VBool (prim_is_cunpred_exc ex)) 296 | | ("is_exctaken_exc", [ ], [VExc (_, ex) ]) -> Some (VBool (prim_is_exctaken_exc ex)) 297 | | ("is_impdef_exc", [ ], [VExc (_, ex) ]) -> Some (VBool (prim_is_impdef_exc ex)) 298 | | ("is_see_exc", [ ], [VExc (_, ex) ]) -> Some (VBool (prim_is_see_exc ex)) 299 | | ("is_undefined_exc", [ ], [VExc (_, ex) ]) -> Some (VBool (prim_is_undefined_exc ex)) 300 | | ("is_unpred_exc", [ ], [VExc (_, ex) ]) -> Some (VBool (prim_is_unpred_exc ex)) 301 | 302 | (* The remaining primops all have side effects *) 303 | | ("ram_init", _, [VInt a; VInt n; VRAM ram; VBits i]) -> Some (prim_init_ram a n ram i; VTuple []) 304 | | ("ram_read", _, [VInt a; VInt n; VRAM ram; VBits i]) -> Some (VBits (prim_read_ram a n ram i.v)) 305 | | ("ram_write", _, [VInt a; VInt n; VRAM ram; VBits i; VBits x]) -> Some (prim_write_ram a n ram i.v x; VTuple []) 306 | 307 | | ("trace_memory_read", _, [VInt a; VInt n; VRAM ram; VInt i; VBits x]) -> Some (prim_trace_memory_write a n ram i x; VTuple []) 308 | | ("trace_memory_write", _, [VInt a; VInt n; VRAM ram; VInt i; VBits x]) -> Some (prim_trace_memory_read a n ram i x; VTuple []) 309 | | ("trace_event", _, [VString s ]) -> Some (prim_trace_event s; VTuple []) 310 | 311 | | ("asl_file_open", _, [VString name; VString mode]) -> Some (VInt (prim_open_file name mode)) 312 | | ("asl_file_write", _, [VInt fd; VString data]) -> Some (prim_write_file fd data; VTuple []) 313 | | ("asl_file_getc", _, [VInt fd ]) -> Some (VInt (prim_getc_file fd)) 314 | | ("print_str", _, [VString s ]) -> Some (prim_print_str s; VTuple []) 315 | | ("print_char", _, [VInt c ]) -> Some (prim_print_char c; VTuple []) 316 | 317 | (* No function matches *) 318 | | _ -> None 319 | ) 320 | 321 | 322 | (****************************************************************) 323 | (** {2 Utility functions on Values} *) 324 | (****************************************************************) 325 | 326 | let extract_bits (loc: AST.l) (x: value) (i: value) (w: value): value = 327 | VBits (prim_extract (to_bits loc x) (to_integer loc i) (to_integer loc w)) 328 | 329 | let extract_bits' (loc: AST.l) (x: value) (i: int) (w: int): value = 330 | VBits (prim_extract (to_bits loc x) (Z.of_int i) (Z.of_int w)) 331 | 332 | let extract_bits'' (loc: AST.l) (x: value) (i: value) (w: value): value = 333 | (match x with 334 | | VInt(x') -> VBits (prim_extract_int x' (to_integer loc i) (to_integer loc w)) 335 | | VBits(x') -> VBits (prim_extract x' (to_integer loc i) (to_integer loc w)) 336 | | _ -> raise (EvalError (loc, "bits or integer expected")) 337 | ) 338 | 339 | let insert_bits (loc: AST.l) (x: value) (i: value) (w: value) (y: value): value = 340 | VBits (prim_insert (to_bits loc x) (to_integer loc i) (to_integer loc w) (to_bits loc y)) 341 | 342 | let insert_bits' (loc: AST.l) (x: value) (i: int) (w: int) (y: value): value = 343 | VBits (prim_insert (to_bits loc x) (Z.of_int i) (Z.of_int w) (to_bits loc y)) 344 | 345 | let rec eval_eq (loc: AST.l) (x: value) (y: value): bool = 346 | (match (x, y) with 347 | | (VBool x', VBool y') -> prim_eq_bool x' y' 348 | | (VEnum x', VEnum y') -> snd x' = snd y' 349 | | (VInt x', VInt y') -> prim_eq_int x' y' 350 | | (VReal x', VReal y') -> prim_eq_real x' y' 351 | | (VBits x', VBits y') -> prim_eq_bits x' y' 352 | | (VString x', VString y') -> String.equal x' y' 353 | | (VTuple xs, VTuple ys) -> List.for_all2 (eval_eq loc) xs ys 354 | | _ -> raise (EvalError (loc, "matchable types expected")) 355 | ) 356 | 357 | let eval_leq (loc: AST.l) (x: value) (y: value): bool = 358 | (match (x, y) with 359 | | (VInt x', VInt y') -> prim_le_int x' y' 360 | | _ -> raise (EvalError (loc, "integer expected")) 361 | ) 362 | 363 | let eval_eq_int (loc: AST.l) (x: value) (y: value): bool = 364 | prim_eq_int (to_integer loc x) (to_integer loc y) 365 | 366 | let eval_eq_bits (loc: AST.l) (x: value) (y: value): bool = 367 | prim_eq_bits (to_bits loc x) (to_bits loc y) 368 | 369 | (* todo: should m be a value or a mask? *) 370 | let eval_inmask (loc: AST.l) (x: value) (m: value): bool = 371 | prim_in_mask (to_bits loc x) (to_mask loc m) 372 | 373 | let eval_add_int (loc: AST.l) (x: value) (y: value): value = 374 | VInt (prim_add_int (to_integer loc x) (to_integer loc y)) 375 | 376 | let eval_sub_int (loc: AST.l) (x: value) (y: value): value = 377 | VInt (prim_sub_int (to_integer loc x) (to_integer loc y)) 378 | 379 | let eval_concat (loc: AST.l) (xs: value list): value = 380 | let xs' = List.map (to_bits loc) xs in 381 | VBits (List.fold_left prim_append_bits empty_bits xs') 382 | 383 | 384 | (****************************************************************) 385 | (** {2 Unknown handling} *) 386 | (****************************************************************) 387 | 388 | (** We might want to change this in the future to model the expected 389 | non-determinism in the spec. 390 | And we might want to augment this with some form of support for 391 | uninitialized values (which would ideally trigger an error). 392 | *) 393 | 394 | let eval_unknown_bits (wd: Primops.bigint): value = 395 | VBits (Primops.mkBits (Z.to_int wd) Z.zero) 396 | 397 | let eval_unknown_ram (a: Primops.bigint): value = 398 | VRAM (Primops.init_ram (char_of_int 0)) 399 | 400 | let eval_unknown_integer (_: unit): value = VInt Z.zero 401 | let eval_unknown_real (_: unit): value = VReal Q.zero 402 | let eval_unknown_string (_: unit): value = VString "" 403 | 404 | (**************************************************************** 405 | * End 406 | ****************************************************************) 407 | -------------------------------------------------------------------------------- /visitor.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * 3 | * Copyright (c) 2001-2003, 4 | * George C. Necula 5 | * Scott McPeak 6 | * Wes Weimer 7 | * Ben Liblit 8 | * All rights reserved. 9 | * 10 | * Redistribution and use in source and binary forms, with or without 11 | * modification, are permitted provided that the following conditions are 12 | * met: 13 | * 14 | * 1. Redistributions of source code must retain the above copyright 15 | * notice, this list of conditions and the following disclaimer. 16 | * 17 | * 2. Redistributions in binary form must reproduce the above copyright 18 | * notice, this list of conditions and the following disclaimer in the 19 | * documentation and/or other materials provided with the distribution. 20 | * 21 | * 3. The names of the contributors may not be used to endorse or promote 22 | * products derived from this software without specific prior written 23 | * permission. 24 | * 25 | * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 26 | * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 27 | * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 28 | * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 29 | * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 30 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 31 | * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 32 | * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 33 | * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 34 | * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 35 | * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | * 37 | *) 38 | 39 | (**************************************************************** 40 | * Visitor support code 41 | * 42 | * The code in this file is copied from George Necula's excellent 43 | * CIL project (https://people.eecs.berkeley.edu/~necula/cil/) 44 | * with minor change to allow it to be used with an arbitrary AST. 45 | ****************************************************************) 46 | 47 | 48 | (**************************************************************** 49 | * Visit action 50 | * 51 | * Visitor methods can request one of four actions on the AST. 52 | ****************************************************************) 53 | 54 | (** Different visiting actions. 'a will be instantiated with [expr], [stmt], 55 | etc. *) 56 | type 'a visitAction = 57 | SkipChildren (** Do not visit the children. Return 58 | the node as it is. *) 59 | | DoChildren (** Continue with the children of this 60 | node. Rebuild the node on return 61 | if any of the children changes 62 | (use == test) *) 63 | | ChangeTo of 'a (** Replace the expression with the 64 | given one *) 65 | | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire 66 | exp is replaced by the first 67 | parameter. Then continue with 68 | the children. On return rebuild 69 | the node if any of the children 70 | has changed and then apply the 71 | function on the node *) 72 | 73 | 74 | (**************************************************************** 75 | * Visitor engine 76 | * 77 | * These functions implement the various actions a visitor can 78 | * request and provide helper functions for writing visitors. 79 | * 80 | * Note that the visitor functions implement a space-saving optimisation: 81 | * if the result would be identical to the input value, they return the 82 | * input value to avoid allocating another copy of the object. 83 | * This optimisation is supported by the mapNoCopy, mapNoCopyList 84 | * and doVisitList functions. 85 | * 86 | * This code is changed from the CIL original by replacing the 87 | * "cilVisitor" type by "'v" so that the code is independent of 88 | * the particular AST it is used with. 89 | ****************************************************************) 90 | 91 | (*** Define the visiting engine ****) 92 | (* visit all the nodes in an ASL tree *) 93 | let doVisit (vis: 'v) 94 | (action: 'a visitAction) 95 | (children: 'v -> 'a -> 'a) 96 | (node: 'a) : 'a = 97 | match action with 98 | SkipChildren -> node 99 | | ChangeTo node' -> node' 100 | | DoChildren -> children vis node 101 | | ChangeDoChildrenPost(node', f) -> f (children vis node') 102 | 103 | (* mapNoCopy is like map but avoid copying the list if the function does not 104 | * change the elements. *) 105 | let rec mapNoCopy (f: 'a -> 'a) = function 106 | [] -> [] 107 | | (i :: resti) as li -> 108 | let i' = f i in 109 | let resti' = mapNoCopy f resti in 110 | if i' != i || resti' != resti then i' :: resti' else li 111 | 112 | let rec mapNoCopyList (f: 'a -> 'a list) = function 113 | [] -> [] 114 | | (i :: resti) as li -> 115 | let il' = f i in 116 | let resti' = mapNoCopyList f resti in 117 | match il' with 118 | [i'] when i' == i && resti' == resti -> li 119 | | _ -> il' @ resti' 120 | 121 | (* not part of original cil framework *) 122 | let rec mapOptionNoCopy (f: 'a -> 'a): ('a option -> 'a option) = function 123 | | None -> None 124 | | (Some x) as ox -> 125 | let x' = f x in 126 | if x' == x then ox else Some x' 127 | 128 | (* A visitor for lists *) 129 | let doVisitList (vis: 'v) 130 | (action: 'a list visitAction) 131 | (children: 'v -> 'a -> 'a) 132 | (node: 'a) : 'a list = 133 | match action with 134 | SkipChildren -> [node] 135 | | ChangeTo nodes' -> nodes' 136 | | DoChildren -> [children vis node] 137 | | ChangeDoChildrenPost(nodes', f) -> 138 | f (mapNoCopy (fun n -> children vis n) nodes') 139 | 140 | (**************************************************************** 141 | * End 142 | ****************************************************************) 143 | --------------------------------------------------------------------------------