├── .gitignore ├── INSTALL ├── Makefile ├── README ├── compiler ├── Makefile ├── ast.ml ├── boundCheck.ml ├── emit.ml ├── error.ml ├── est.ml ├── estCompile.ml ├── estNormalizePatterns.ml ├── estOfIst.ml ├── estOptim.ml ├── estPp.ml ├── estSubst.ml ├── eval.ml ├── extractFuns.ml ├── global.ml ├── id.ml ├── ident.ml ├── ident.mli ├── ids.ml ├── ist.ml ├── istOfStast.ml ├── istOptim.ml ├── istPp.ml ├── istRecords.ml ├── istTail.ml ├── lexer.mll ├── linearCheck.ml ├── llst.ml ├── llstFree.ml ├── llstOfEst.ml ├── llstOptim.ml ├── llstPp.ml ├── main.ml ├── naming.ml ├── nast.ml ├── nastCheck.ml ├── nastExpand.ml ├── neast.ml ├── neastCheck.ml ├── parser.mly ├── pos.ml ├── recordCheck.ml ├── stast.ml ├── stastCheck.ml ├── stastOfTast.ml ├── tast.ml ├── typing.ml └── utils.ml ├── conf └── size.c ├── configure ├── licence.txt ├── stdlib ├── Makefile ├── array.c ├── array.lml ├── box.lml ├── closure.lml ├── debug.c ├── farray.lml ├── iarray.lml ├── liml.h ├── list.lml ├── math.c ├── math.lml ├── option.lml ├── pervasives.lml ├── print.c ├── print.lml ├── share.c ├── share.lml ├── string.c ├── string.lml ├── thread.c └── thread.lml └── test ├── array_test.lml ├── examples └── map.lml ├── llvm_bugs ├── bug_call_sin.as ├── bug_call_sin.lml ├── bug_tail_call_opt.lml └── bug_trampoline.as ├── my_main.c ├── parsort.lml ├── regression ├── unit.lml └── unit2.lml ├── shootout ├── Makefile ├── README ├── bintree.lml ├── bintree_2.lml ├── bintree_main.c ├── custom_lib.c ├── fankuch.lml ├── fankuch_main.c ├── nbody.lml ├── parBintree.lml ├── spectral.lml └── spectral_main.c ├── test_future.lml ├── test_share.lml └── unit ├── go.sh ├── monad.ml ├── test_array1.lml ├── test_array2.lml ├── test_basic.lml ├── test_char.lml ├── test_closure.lml ├── test_core.lml ├── test_eval.lml ├── test_float.lml ├── test_linear.lml ├── test_list.lml ├── test_poly.lml ├── test_string.lml └── test_typing.lml /.gitignore: -------------------------------------------------------------------------------- 1 | *.cmx 2 | *.cmi 3 | *.cmxa 4 | *.a 5 | *.o 6 | *.so* 7 | *.cmo 8 | *.annot 9 | .*.swp 10 | *.run 11 | parser.ml 12 | parser.mli 13 | lexer.ml 14 | .depend 15 | Makefile.config 16 | compiler/limlc 17 | limlc 18 | limlc.bc 19 | a.out 20 | compiler/limlc.bc 21 | compiler/liml 22 | stdlib/config.h 23 | *~ 24 | stdlib/libliml.lmli 25 | \#* 26 | parser.output 27 | TODO 28 | *.s 29 | *.bc 30 | genGlobals.ml -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | DEPENDENCIES: 2 | 3 | To compile linearML, you need: 4 | 5 | * a unix platform (won't work with windows) 6 | * a C compiler (only test with gcc) 7 | * a C++ compiler (only tested with g++) 8 | * llvm-2.8 9 | * ocaml-3.11 (or higher) 10 | * llvm-ocaml bindings (usually installed with llvm-2.8) 11 | 12 | 13 | Instructions install LinearML 14 | 15 | step1: 16 | 17 | ./configure 18 | 19 | step2: 20 | 21 | make 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | default: compiler/limlc 3 | 4 | .PHONY: compiler/limlc 5 | 6 | compiler/limlc: Makefile.config 7 | cd compiler && make 8 | cd stdlib && make 9 | cp compiler/limlc . 10 | 11 | stdlib/libliml.lmli: compiler/limlc 12 | @echo "Compiling the standard library" 13 | cd stdlib && make 14 | 15 | clean: 16 | rm -f *~ 17 | cd compiler && make clean 18 | cd stdlib && make clean -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | I am providing code in this repository to you under an open source license. 2 | Because this is my personal repository, the license you receive to my code if from 3 | me and not my employer (Facebook). 4 | 5 | LinearML (or LiML) is a programming language designed to write efficient parallel programs. 6 | Its main characteristics are: 7 | 8 | * Purely functional 9 | * Statically typed 10 | * Strict evaluation order 11 | 12 | In LiML, the default is, every value has a linear type, this implies: 13 | 14 | * Thread-safe copy-less message-passing between threads 15 | * Thread-safe IOs 16 | * In-place updates for the vast majority of operations (better cache hits) 17 | * Statically enforced memory management. 18 | In other words, there is no garbage collector, the memory usage is safe, it's garanteed statically ! 19 | 20 | 21 | To compile LiML, follow the instructions in INSTALL -------------------------------------------------------------------------------- /compiler/Makefile: -------------------------------------------------------------------------------- 1 | 2 | -include ../Makefile.config 3 | 4 | OCAMLC_OPTS = -dtypes -warn-error A 5 | LIBS = unix.cma $(LLVM_LIBS) 6 | LIBSOPT = $(LIBS:.cma=.cmxa) 7 | INCLUDE = -I $(OCAMLLIB) 8 | CLIBS = $($(OCAMLLIB), $(LLVM_LIBS:.cma=.a)) 9 | 10 | default: limlc 11 | 12 | .PHONY: limlc 13 | 14 | OBJECTS_ML = \ 15 | genGlobals.ml\ 16 | global.ml\ 17 | pos.ml\ 18 | ident.ml\ 19 | utils.ml\ 20 | error.ml\ 21 | ast.ml\ 22 | lexer.ml\ 23 | parser.ml\ 24 | nast.ml\ 25 | naming.ml\ 26 | nastCheck.ml\ 27 | neast.ml\ 28 | nastExpand.ml\ 29 | neastCheck.ml\ 30 | tast.ml\ 31 | typing.ml\ 32 | stast.ml\ 33 | stastOfTast.ml\ 34 | stastCheck.ml\ 35 | recordCheck.ml\ 36 | linearCheck.ml\ 37 | boundCheck.ml\ 38 | ist.ml\ 39 | istPp.ml\ 40 | istOfStast.ml\ 41 | istTail.ml\ 42 | extractFuns.ml\ 43 | est.ml\ 44 | estSubst.ml\ 45 | estPp.ml\ 46 | estOfIst.ml\ 47 | estOptim.ml\ 48 | estCompile.ml\ 49 | estNormalizePatterns.ml\ 50 | llst.ml\ 51 | llstPp.ml\ 52 | llstOfEst.ml\ 53 | llstFree.ml\ 54 | llstOptim.ml\ 55 | emit.ml\ 56 | eval.ml\ 57 | main.ml 58 | # istAdhoc.ml 59 | 60 | # boundCheck2.ml\ 61 | # id.ml\ 62 | # ast.ml\ 63 | # astOfCst.ml\ 64 | # statesOfAst.ml 65 | # istRecords.ml\ 66 | istOptim.ml\ 67 | 68 | 69 | OBJECTS_CMO = $(OBJECTS_ML:.ml=.cmo) 70 | OBJECTS_CMX = $(OBJECTS_ML:.ml=.cmx) 71 | 72 | limlc: $(OBJECTS_CMX) 73 | echo $(LIBS) 74 | $(OCAMLOPT) -cc $(CPP) $(INCLUDE) \ 75 | -linkall $(CLIBS) $(LIBSOPT) $(OBJECTS_CMX) \ 76 | -o $@ 77 | 78 | limlc.bc: $(OBJECTS_CMO) 79 | $(OCAMLC) $(OCAMLC_OPTS) -g -cc $(CPP) \ 80 | $(INCLUDE) $(LIBS) $(OBJECTS_CMO) \ 81 | -o $@ 82 | 83 | ############################################################################## 84 | 85 | %.cmo : %.ml 86 | $(OCAMLC) $(INCLUDE) $(OCAMLC_CFLAGS) -c -g $< 87 | 88 | %.cmi : %.mli 89 | $(OCAMLC) $(OCAMLOPT_CFLAGS) $(INCLUDE) $< 90 | 91 | %.cmx : %.ml 92 | $(OCAMLOPT) $(OCAMLOPT_CFLAGS) $(INCLUDE) $(PP) -annot -c $< 93 | 94 | %.ml : %.mll 95 | $(OCAMLLEX) $< 96 | 97 | %.ml %.mli : %.mly 98 | $(OCAMLYACC) -v $< 99 | 100 | ############################################################################### 101 | 102 | .depend: $(OBJECTS_ML) 103 | $(OCAMLDEP) -native -slash $(INCLUDE) $(OBJECTS_ML) > .depend 104 | 105 | clean: 106 | rm -f *.cm* pkl *~ lexer.ml parser.ml parser.mli lexer.mli *.o* \#* 107 | rm -f limlc limlc.bc liml liml.bc *.annot .depend 108 | rm -f test/*.o test/*.s 109 | rm -f test/*.bc test/*~ 110 | cd ../stdlib && make clean 111 | 112 | -include .depend 113 | -------------------------------------------------------------------------------- /compiler/ast.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | 34 | type id = Pos.t * string 35 | type pstring = Pos.t * string 36 | 37 | type fun_kind = Cfun | Lfun 38 | 39 | type program = module_ list 40 | 41 | and module_ = { 42 | md_sig: bool ; 43 | md_id: id ; 44 | md_defs: def list ; 45 | } 46 | 47 | and type_def = (id * id list) * type_expr 48 | 49 | and type_expr = Pos.t * type_expr_ 50 | and type_expr_ = 51 | | Tany 52 | | Tvar of id 53 | | Tid of id 54 | | Tapply of type_expr * type_expr list 55 | | Ttuple of type_expr list 56 | | Tpath of id * id 57 | | Tfun of fun_kind * type_expr * type_expr 58 | | Talgebric of (id * type_expr option) list 59 | | Trecord of (id * type_expr) list 60 | | Tabbrev of type_expr 61 | | Tabs of id list * type_expr 62 | | Tabstract 63 | 64 | and def = 65 | | Dmodule of id * id 66 | | Dlet of id * pat list * expr 67 | | Dtype of link * (id * type_expr) list 68 | | Dval of link * id * type_expr * extern_def 69 | 70 | and link = 71 | | Abstract 72 | | Public 73 | | Private 74 | 75 | and extern_def = 76 | | Ext_none 77 | | Ext_C of pstring (* C function *) 78 | | Ext_Asm of pstring (* Assembly function *) 79 | | Ext_I (* Internally defined *) 80 | 81 | and tpat = pat * type_expr 82 | and pat = Pos.t * pat_ 83 | and pat_ = 84 | | Punit 85 | | Pany 86 | | Pid of id 87 | | Pchar of pstring 88 | | Pint of pstring 89 | | Pbool of bool 90 | | Pfloat of pstring 91 | | Pstring of pstring 92 | | Pcstr of id 93 | | Pvariant of id * pat 94 | | Pecstr of id * id 95 | | Pevariant of id * id * pat 96 | | Precord of pat_field list 97 | | Pbar of pat * pat 98 | | Ptuple of pat list 99 | | Pas of id * pat 100 | 101 | and pat_field = Pos.t * pat_field_ 102 | and pat_field_ = 103 | | PFany 104 | | PFid of id 105 | | PField of id * pat 106 | 107 | and expr = Pos.t * expr_ 108 | and expr_ = 109 | | Eunit 110 | | Ebool of bool 111 | | Eid of id 112 | | Eint of pstring 113 | | Efloat of pstring 114 | | Echar of pstring 115 | | Estring of pstring 116 | | Ebinop of bop * expr * expr 117 | | Euop of uop * expr 118 | | Etuple of expr list 119 | | Ecstr of id 120 | | Eecstr of id * id 121 | | Eefield of expr * id * id 122 | | Eextern of id * id 123 | | Erecord of field list 124 | | Efield of expr * id 125 | | Ematch of expr * (pat * expr) list 126 | | Elet of pat * expr * expr 127 | | Eif of expr * expr * expr 128 | | Efun of fun_kind * bool * tpat list * expr 129 | | Eapply of expr * expr list 130 | | Ewith of expr * field list 131 | | Eseq of expr * expr 132 | | Eobs of id 133 | 134 | and field = 135 | | Eflocl of id * expr 136 | | Efextr of id * id * expr 137 | 138 | and bop = 139 | | Eeq 140 | | Ediff 141 | | Elt 142 | | Elte 143 | | Egt 144 | | Egte 145 | | Eplus 146 | | Eminus 147 | | Estar 148 | | Emod 149 | | Ediv 150 | | Eor 151 | | Eand 152 | | Eband 153 | 154 | and uop = 155 | | Euminus 156 | -------------------------------------------------------------------------------- /compiler/est.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | 34 | type id = Ident.t 35 | type label = Ident.t 36 | type pstring = string 37 | 38 | type program = module_ list 39 | 40 | and module_ = { 41 | md_sig: bool; 42 | md_id: id ; 43 | md_decls: Ist.decl list ; 44 | md_defs: def list ; 45 | } 46 | 47 | and def = { 48 | df_id: id ; 49 | df_kind: Ast.fun_kind ; 50 | df_args: ty_id list ; 51 | df_return: ty_id list ; 52 | df_body: block list ; 53 | } 54 | 55 | and ty_id = Ist.type_expr * id 56 | and ty_idl = ty_id list 57 | 58 | and pat = pat_el list 59 | and pat_el = Ist.type_expr * pat_ 60 | and pat_ = 61 | | Pany 62 | | Pid of id 63 | | Pvariant of id * pat 64 | | Precord of id option * pfield list 65 | | Pas of id * pat_el 66 | 67 | and pfield = id * pat 68 | 69 | and block = { 70 | bl_id: label ; 71 | bl_phi: phi list ; 72 | bl_eqs: equation list ; 73 | bl_ret: ret ; 74 | } 75 | 76 | and ret = 77 | | Lreturn of ty_idl 78 | | Return of bool * ty_idl 79 | | Jump of label 80 | | If of ty_id * label * label 81 | | Match of ty_idl * (pat * label) list 82 | 83 | and phi = id * Ist.type_expr * (id * label) list 84 | 85 | and equation = ty_idl * expr 86 | 87 | and expr = 88 | | Enull 89 | | Eid of ty_id 90 | | Evalue of Ist.value 91 | | Evariant of id * ty_idl 92 | | Ebinop of Ast.bop * ty_id * ty_id 93 | | Euop of Ast.uop * ty_id 94 | | Erecord of (id * ty_idl) list 95 | | Ewith of ty_id * (id * ty_idl) list 96 | | Efield of ty_id * id 97 | | Ematch of ty_idl * (pat * expr) list 98 | | Ecall of label 99 | | Eapply of bool * Ast.fun_kind * ty_id * ty_idl 100 | | Eseq of ty_id * ty_idl 101 | | Eif of ty_id * label * label 102 | | Eis_null of ty_id 103 | | Efree of ty_id 104 | | Eget of ty_id * ty_id 105 | | Eset of ty_id * ty_id * ty_id 106 | | Eswap of ty_id * ty_id * ty_id 107 | | Epartial of ty_id * ty_idl 108 | 109 | -------------------------------------------------------------------------------- /compiler/estNormalizePatterns.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | open Ist 34 | open Est 35 | 36 | module Env = struct 37 | 38 | let rec program mdl = 39 | let t = IMap.empty in 40 | let t = List.fold_left module_ t mdl in 41 | t 42 | 43 | and module_ t md = 44 | List.fold_left decl t md.md_decls 45 | 46 | and decl t = function 47 | | Dalgebric td -> tdef t td 48 | | _ -> t 49 | 50 | and tdef t td = 51 | let vl = IMap.fold ( 52 | fun x (_, args) acc -> 53 | match args with 54 | | [] -> ISet.add x acc 55 | | _ -> acc 56 | ) td.td_map ISet.empty in 57 | IMap.add td.td_id vl t 58 | 59 | end 60 | 61 | module EnvCounts = struct 62 | 63 | let rec program mdl = 64 | let t = IMap.empty in 65 | let t = List.fold_left module_ t mdl in 66 | t 67 | 68 | and module_ t md = 69 | List.fold_left decl t md.md_decls 70 | 71 | and decl t = function 72 | | Dalgebric td -> tdef t td 73 | | _ -> t 74 | 75 | and tdef t td = 76 | let n = IMap.fold ( 77 | fun _ _ acc -> 1 + acc 78 | ) td.td_map 0 in 79 | IMap.add td.td_id n t 80 | 81 | end 82 | 83 | module Normalize = struct 84 | 85 | let rec default = function 86 | | [] -> None 87 | | ([_, Pany], a) :: _ -> Some a 88 | | _ :: rl -> default rl 89 | 90 | let rec type_expr t = function 91 | | Tany 92 | | Tprim _ 93 | | Tvar _ -> None 94 | | Tapply (x, [ty]) when x = Naming.tobs -> type_expr t ty 95 | | Tid x 96 | | Tapply (x, _) -> (try Some (IMap.find x t) with Not_found -> None) 97 | | Tfun _ -> None 98 | 99 | let rec pmatch t ty al = 100 | match type_expr t ty with 101 | | None -> al 102 | | Some vs -> action vs al 103 | 104 | and action vs al = 105 | match al with 106 | | [] -> [] 107 | | ([_, Pvariant (x, [])], _) as a :: rl -> 108 | let vs = ISet.remove x vs in 109 | let rl = action vs rl in 110 | a :: rl 111 | | ([ty, Pvariant (_, _)], _) :: rl -> 112 | add_cases ty vs (default rl) al 113 | | ([_, Pany], _) :: _ -> al 114 | | _ -> assert false 115 | 116 | and add_cases ty vs d al = 117 | match d with 118 | | None -> al 119 | | Some d -> 120 | ISet.fold ( 121 | fun v al -> 122 | ([ty, Pvariant (v, [])], d) :: al) 123 | vs al 124 | 125 | end 126 | 127 | (* 128 | module RemoveOption = struct 129 | 130 | let is_option al = 131 | let l = List.map fst al in 132 | try List.iter ( 133 | function 134 | | [_, Pvariant (x, _)] when x = Naming.none || x = Naming.some -> 135 | raise Exit 136 | | _ -> () 137 | ) l ; false 138 | with Exit -> true 139 | 140 | let rec make_none al = 141 | match al with 142 | | [] -> assert false 143 | | ([_, Pvariant (x, [])], lbl) :: _ when x = Naming.none -> 144 | lbl 145 | | _ :: rl -> make_none rl 146 | 147 | let rec make_some v t al = 148 | match al with 149 | | [] -> assert false 150 | | ([_, Pany], lbl) :: _ -> 151 | t, lbl 152 | | ([_, Pvariant (x, [ty, Pid y])], lbl) :: _ when x = Naming.some -> 153 | let casts = try IMap.find lbl t with Not_found -> [] in 154 | IMap.add lbl (((ty, y), v) :: casts) t, lbl 155 | | _ :: rl -> make_some v t rl 156 | 157 | let add_cast t bl = 158 | if IMap.mem bl.bl_id t 159 | then 160 | let casts = IMap.find bl.bl_id t in 161 | let eqs = List.fold_right ( 162 | fun (x, y) acc -> ([x], Est.Eid y) :: acc 163 | ) casts bl.bl_eqs in 164 | { bl with bl_eqs = eqs } 165 | else bl 166 | 167 | let rec def df = 168 | let t = IMap.empty in 169 | let t, bll = List.fold_right block df.df_body (t, []) in 170 | let bll = List.map (add_cast t) bll in 171 | let df = { df with df_body = bll } in 172 | df 173 | 174 | and block bl (t, acc) = 175 | let work, rt = ret t bl.bl_ret in 176 | match work with 177 | | None -> t, bl :: acc 178 | | Some (t, eqs) -> 179 | t, { bl with bl_eqs = bl.bl_eqs @ eqs ; bl_ret = rt } :: acc 180 | 181 | and ret t = function 182 | | Match ([v], al) when is_option al -> 183 | let cid = Tprim Tbool, Ident.tmp() in 184 | let eqs = [[cid], Eis_null v] in 185 | let lbl1 = make_none al in 186 | let t, lbl2 = make_some v t al in 187 | Some (t, eqs), If (cid, lbl1, lbl2) 188 | | x -> None, x 189 | 190 | 191 | end 192 | *) 193 | 194 | module RemoveUnderscore = struct 195 | 196 | let rec type_expr t = function 197 | | Tany 198 | | Tprim _ 199 | | Tvar _ -> None 200 | | Tapply (x, [ty]) when x = Naming.tobs -> type_expr t ty 201 | | Tid x 202 | | Tapply (x, _) -> (try Some (IMap.find x t) with Not_found -> None) 203 | | Tfun _ -> None 204 | 205 | let rec pmatch t ty al = 206 | match type_expr t ty with 207 | | None -> al 208 | | Some n -> action n 0 al 209 | 210 | and action total n al = 211 | match al with 212 | | [] -> [] 213 | | ([_, Pvariant (_, _)], _) as a :: rl -> 214 | let rl = action total (n+1) rl in 215 | a :: rl 216 | | [[_, Pany], _] when n = total -> [] 217 | | al -> al 218 | 219 | end 220 | 221 | type env = { 222 | noargs: ISet.t IMap.t ; 223 | counts: int IMap.t ; 224 | } 225 | 226 | let rec program mdl = 227 | let noargs = Env.program mdl in 228 | let counts = EnvCounts.program mdl in 229 | let t = { noargs = noargs ; counts = counts } in 230 | List.rev_map (module_ t) mdl 231 | 232 | and module_ t md = 233 | let defs = List.map (def t) md.md_defs in 234 | { md with md_defs = defs } 235 | 236 | and def t df = 237 | let body = List.map (block t) df.df_body in 238 | let df = { df with df_body = body } in 239 | (* let df = RemoveOption.def df in *) 240 | df 241 | 242 | and block t bl = 243 | let rt = ret t bl.bl_ret in 244 | { bl with bl_ret = rt } 245 | 246 | and ret t = function 247 | | Lreturn _ 248 | | Return _ 249 | | Jump _ 250 | | If _ as x -> x 251 | | Match ([ty, _] as c, al) -> 252 | let al = Normalize.pmatch t.noargs ty al in 253 | let al = RemoveUnderscore.pmatch t.counts ty al in 254 | let al = List.sort compare_pat al in 255 | Match (c, al) 256 | | Match _ -> assert false 257 | 258 | and compare_pat (x, _) (y, _) = 259 | match snd (List.hd x), snd (List.hd y) with 260 | | Pvariant (x, []), Pvariant (y, []) -> Ident.compare x y 261 | | Pvariant (_, []), _ -> -1 262 | | _, Pvariant (_, []) -> 1 263 | | Pvariant (x, _), Pvariant (y, _) -> Ident.compare x y 264 | | Pvariant (_, _), _ -> -1 265 | | _, Pvariant (_, _) -> 1 266 | | x, y -> Pervasives.compare x y 267 | 268 | 269 | -------------------------------------------------------------------------------- /compiler/estOptim.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | open Est 34 | 35 | 36 | module BlockOccs = struct 37 | 38 | let add t x = 39 | let n = try IMap.find x t with Not_found -> 0 in 40 | let n = n+1 in 41 | IMap.add x n t 42 | 43 | let rec def df = 44 | let t = List.fold_left block IMap.empty df.df_body in 45 | add t ((List.hd df.df_body).bl_id) 46 | 47 | and block t bl = 48 | let t = List.fold_left equation t bl.bl_eqs in 49 | let t = ret t bl.bl_ret in 50 | t 51 | 52 | and equation t (_, e) = expr t e 53 | 54 | and ret t = function 55 | | Lreturn _ -> assert false 56 | | Return _ -> t 57 | | Jump lbl -> add t lbl 58 | | If (_, lbl1, lbl2) -> 59 | let t = add t lbl1 in 60 | let t = add t lbl2 in 61 | t 62 | | Match (_, al) -> 63 | List.fold_left ( 64 | fun t (_, l) -> 65 | add t l 66 | ) t al 67 | 68 | and expr t = function 69 | | Eif (_, lbl1, lbl2) -> 70 | let t = add t lbl1 in 71 | let t = add t lbl2 in 72 | t 73 | | Ecall lbl -> add t lbl 74 | | _ -> t 75 | 76 | end 77 | 78 | module Redirect = struct 79 | 80 | let add_block t bl = 81 | if bl.bl_eqs = [] && bl.bl_phi = [] 82 | then 83 | match bl.bl_ret with 84 | | Jump lbl -> 85 | IMap.add bl.bl_id lbl t 86 | | _ -> t 87 | else t 88 | 89 | let get x t = 90 | try IMap.find x t 91 | with Not_found -> x 92 | 93 | let rec def df = 94 | let t = List.fold_left add_block IMap.empty df.df_body in 95 | let body = List.map (block t) df.df_body in 96 | { df with df_body = body } 97 | 98 | and block t bl = 99 | let ret = return t bl.bl_ret in 100 | { bl with 101 | bl_phi = List.map (phi t) bl.bl_phi ; 102 | bl_ret = ret ; 103 | } 104 | 105 | and phi t (x, ty, l) = 106 | x, ty, List.map (fun (x, lbl) -> x, get lbl t) l 107 | 108 | and return t = function 109 | | Jump lbl -> Jump (get lbl t) 110 | | If (x, lbl1, lbl2) -> 111 | If (x, get lbl1 t, get lbl2 t) 112 | | Match (e, al) -> Match (e, List.map (action t) al) 113 | | x -> x 114 | 115 | and action t (p, lbl) = p, get lbl t 116 | 117 | end 118 | 119 | 120 | (*module InlineBlocks = struct 121 | 122 | let get_occur x t = 123 | try IMap.find x t with Not_found -> 0 124 | 125 | let add_block acc bl = 126 | IMap.add bl.bl_id bl acc 127 | 128 | let rec def df = 129 | let t = BlockOccs.def df in 130 | let bls = List.fold_left add_block IMap.empty df.df_body in 131 | let body = List.fold_right (block bls t) df.df_body [] in 132 | { df with df_body = body } 133 | 134 | and block bls t bl acc = 135 | let eqs = equation bls t bl.bl_eqs in 136 | { bl with bl_eqs = eqs } :: acc 137 | 138 | and equation bls t = function 139 | | [] -> [] 140 | | [Jump lbl] when get_occur lbl t = 1 -> 141 | (IMap.find lbl bls).bl_eqs 142 | | x :: rl -> x :: equation bls t rl 143 | 144 | end *) 145 | 146 | (*module Remove = struct 147 | 148 | let get_occur x t = 149 | try IMap.find x t with Not_found -> 0 150 | 151 | let rec def df = 152 | let t = BlockOccs.def df in 153 | let body = List.fold_right (block t) df.df_body [] in 154 | { df with df_body = body } 155 | 156 | and block t bl acc = 157 | if get_occur bl.bl_id t = 0 158 | then acc 159 | else bl :: acc 160 | end 161 | *) 162 | 163 | let rec def df = 164 | let df = Redirect.def df in 165 | (* let df = InlineBlocks.def df in 166 | let df = Remove.def df in *) 167 | df 168 | -------------------------------------------------------------------------------- /compiler/estPp.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | open Ist 34 | open Est 35 | 36 | let n = ref 0 37 | let space() = 38 | let rec aux n = if n = 0 then () else (o " " ; aux (n-1)) in 39 | aux !n 40 | 41 | let nl() = o "\n" ; space() 42 | 43 | let push() = n := !n + 2 44 | let pop() = n := !n - 2 45 | 46 | let id x = o (Ident.debug x) 47 | let label x = o (Ident.debug x) 48 | let pstring x = o x 49 | 50 | let rec program mdl = 51 | List.iter module_ mdl 52 | 53 | and module_ md = 54 | o "module " ; 55 | id md.md_id ; 56 | o " = struct" ; 57 | push() ; 58 | nl() ; 59 | List.iter def md.md_defs ; 60 | pop() ; 61 | o "end" ; 62 | nl() 63 | 64 | and def df = 65 | id df.df_id ; 66 | o " " ; 67 | ty_idl df.df_args ; 68 | o " returns " ; 69 | ty_idl df.df_return ; 70 | o " = " ; 71 | push() ; 72 | List.iter block df.df_body ; 73 | pop() ; 74 | nl() ; nl() ; 75 | 76 | and type_expr = function 77 | | Tany -> o "void*" 78 | | Tvar x -> id x 79 | | Tprim tp -> type_prim tp 80 | | Tid x -> id x 81 | | Tapply (x, tyl) -> o "(" ; type_expr_list tyl ; o ") " ; id x 82 | | Tfun (k, tyl1, tyl2) -> 83 | type_expr_list tyl1 ; 84 | o (match k with Ast.Cfun -> " #" | Ast.Lfun -> " ") ; 85 | o "-> " ; 86 | type_expr_list tyl2 87 | 88 | and type_expr_list l = 89 | print_list o (fun _ x -> type_expr x) ", " l 90 | 91 | and type_prim = function 92 | | Tunit -> o "unit" 93 | | Tbool -> o "bool" 94 | | Tchar -> o "char" 95 | | Tint -> o "int" 96 | | Tfloat -> o "float" 97 | | Tstring -> o "string" 98 | 99 | and pat pl = print_list o pat_el ", " pl 100 | and pat_el _ p = pat_ (snd p) 101 | and pat_ = function 102 | | Pany -> o "_" 103 | | Pid x -> id x 104 | | Pvariant (x, p) -> id x ; o "(" ; pat p ; o ")" 105 | | Precord (ido, pfl) -> 106 | o "{ " ; maybe id ido ; List.iter pfield pfl ; o " }" 107 | | Pas (x, p) -> o "(" ; id x ; o " as " ; pat_ (snd p) ; o ")" 108 | 109 | and pfield (x, p) = 110 | id x ; o " = " ; pat p ; o " ; " 111 | 112 | and idl = List.iter (fun (_, x) -> id x ; o " ") 113 | and ty_idl l = 114 | List.iter ( 115 | fun (ty, x) -> o "(" ; id x ; o ": " ; type_expr ty ; o ") " 116 | ) l 117 | 118 | and block bl = 119 | nl() ; 120 | id bl.bl_id ; 121 | o ":" ; 122 | nl() ; 123 | push() ; 124 | nl() ; 125 | if bl.bl_phi <> [] then (o "phi: " ; nl() ; List.iter phi bl.bl_phi ; nl()) ; 126 | List.iter equation bl.bl_eqs ; 127 | (match bl.bl_ret with 128 | | Lreturn l -> (o "lreturn " ; List.iter (fun (_, x) -> id x ; o " ") l) ; 129 | | Return (tail, l) -> 130 | (o "return[" ; 131 | if tail then o "true] " else o "false] " ; 132 | List.iter (fun (_, x) -> id x ; o " ") l) ; 133 | | Jump x -> o "jump " ; id x 134 | | If (x, l1, l2) -> 135 | o "Iif " ; tid x ; o " then jump " ; label l1 ; 136 | o " else jump " ; label l2 ; 137 | | Match (xl, al) -> 138 | o "match " ; idl xl ; push() ; nl() ; List.iter maction al ; pop() 139 | 140 | ) ; 141 | pop() ; 142 | nl() 143 | 144 | and phi (x, _, l) = 145 | id x ; o " <- " ; 146 | List.iter (fun (x, lbl) -> o "(" ; id x ; o ", " ; label lbl ; o ") ; ") l ; 147 | nl() 148 | 149 | and equation (idl, e) = 150 | ty_idl idl ; 151 | o " = " ; 152 | expr e ; 153 | nl() 154 | 155 | and expr = function 156 | | Enull -> o "null" 157 | | Eid x -> tid x 158 | | Evalue v -> value v 159 | | Evariant (x, ty_idl) -> id x ; o "(" ; idl ty_idl ; o ")" 160 | | Ebinop (bop, id1, id2) -> binop bop ; o " " ; tid id1 ; o " " ; tid id2 161 | | Euop (uop, x) -> unop uop ; o " " ; tid x 162 | | Erecord fdl -> o "{" ; List.iter field fdl ; o "}" 163 | | Ewith (x, fdl) -> o "{" ; tid x ; List.iter field fdl ; o "}" 164 | | Efield (x, y) -> tid x ; o "." ; id y 165 | | Ematch (xl, al) -> 166 | o "match " ; idl xl ; push() ; nl() ;List.iter action al ; pop() 167 | | Eapply (_, fk, x, l) -> 168 | o "call[" ; 169 | o (match fk with Ast.Cfun -> "C] " | Ast.Lfun -> "L] ") ; 170 | tid x ; o " " ; idl l 171 | | Eseq _ -> failwith "TODO seq" 172 | | Ecall x -> o "lcall " ; o (Ident.debug x) 173 | | Eif (x, l1, l2) -> 174 | o "if " ; tid x ; o " then lcall " ; label l1 ; 175 | o " else lcall " ; label l2 176 | | Eis_null x -> o "is_null " ; id (snd x) 177 | | Efree x -> o "free " ; id (snd x) 178 | | Eget (x, y) -> o "get " ; id (snd x) ; id (snd y) 179 | | Eset (x, y, z) -> o "set " ; id (snd x) ; id (snd y) ; id (snd z) 180 | | Eswap (x, y, z) -> o "swap " ; id (snd x) ; id (snd y) ; id (snd z) 181 | | Epartial (f, e) -> o "partial " ; id (snd f) ; ty_idl e 182 | 183 | and field (x, l) = id x ; o " = " ; idl l 184 | and action (p, e) = 185 | pat p ; o " -> " ; expr e ; nl() 186 | 187 | and maction (p, lbl) = 188 | pat p ; o " -> jump " ; id lbl ; nl() 189 | 190 | and tid (_, x) = id x 191 | 192 | and value = function 193 | | Ist.Eunit -> o "unit" 194 | | Ist.Ebool b -> o (string_of_bool b) 195 | | Ist.Eint x -> o x 196 | | Ist.Efloat x -> o x 197 | | Ist.Echar x -> o x 198 | | Ist.Estring x -> o x 199 | 200 | and binop = function 201 | | Ast.Eeq -> o "eq" 202 | | Ast.Ediff -> o "diff" 203 | | Ast.Elt -> o "lt" 204 | | Ast.Elte -> o "lte" 205 | | Ast.Egt -> o "gt" 206 | | Ast.Egte -> o "gte" 207 | | Ast.Eplus -> o "plus" 208 | | Ast.Eminus -> o "minus" 209 | | Ast.Emod -> o "mod" 210 | | Ast.Estar -> o "star" 211 | | Ast.Ediv -> o "div" 212 | | Ast.Eand -> o "and" 213 | | Ast.Eor -> o "or" 214 | | Ast.Eband -> o "&" 215 | 216 | and unop = function 217 | | Ast.Euminus -> o "uminus" 218 | -------------------------------------------------------------------------------- /compiler/estSubst.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | open Est 34 | 35 | 36 | let rec id t x = try id t (IMap.find x t) with Not_found -> x 37 | 38 | let rec def t df = 39 | { Est.df_id = id t df.df_id ; 40 | Est.df_kind = df.df_kind ; 41 | Est.df_args = ty_idl t df.df_args; 42 | Est.df_return = ty_idl t df.df_return ; 43 | Est.df_body = List.map (block t) df.df_body ; 44 | } 45 | 46 | and ty_id t (ty, x) = ty, id t x 47 | and ty_idl t l = List.map (ty_id t) l 48 | 49 | and block t bl = { 50 | Est.bl_id = bl.bl_id ; 51 | Est.bl_phi = List.map (phi t) bl.bl_phi ; 52 | Est.bl_eqs = List.map (equation t) bl.bl_eqs ; 53 | Est.bl_ret = ret t bl.bl_ret ; 54 | } 55 | 56 | and phi t (x, ty, l) = id t x, ty, List.map (fun (x, y) -> id t x, y) l 57 | 58 | and ret t = function 59 | | Lreturn l -> Lreturn (ty_idl t l) 60 | | Return (b, l) -> Return (b, ty_idl t l) 61 | | Jump x -> Jump x 62 | | If (c, l1, l2) -> If (ty_id t c, l1, l2) 63 | | Match (cl, al) -> Match (ty_idl t cl, al) 64 | 65 | and equation t (idl, e) = ty_idl t idl, expr t e 66 | 67 | and expr t = function 68 | | Enull -> Enull 69 | | Eid x -> Eid (ty_id t x) 70 | | Evalue _ as e -> e 71 | | Evariant (x, idl) -> Evariant (x, ty_idl t idl) 72 | | Ebinop (bop, x1, x2) -> Ebinop (bop, ty_id t x1, ty_id t x2) 73 | | Euop (uop, x) -> Euop (uop, ty_id t x) 74 | | Erecord fdl -> Erecord (fields t fdl) 75 | | Ewith (x, fdl) -> Ewith (ty_id t x, fields t fdl) 76 | | Efield (x, y) -> Efield (ty_id t x, y) 77 | | Ematch (l, al) -> Ematch (ty_idl t l, actions t al) 78 | | Ecall _ as e -> e 79 | | Eapply (b, fk, x, l) -> Eapply (b, fk, ty_id t x, ty_idl t l) 80 | | Eseq (x, xl) -> Eseq (ty_id t x, ty_idl t xl) 81 | | Eif (x1, l1, l2) -> Eif (ty_id t x1, l1, l2) 82 | | Eis_null x -> Eis_null (ty_id t x) 83 | | Efree x -> Efree (ty_id t x) 84 | | Eget (a, i) -> Eget (ty_id t a, ty_id t i) 85 | | Eset (a, i, v) -> Eset (ty_id t a, ty_id t i, ty_id t v) 86 | | Eswap (a, i, v) -> Eswap (ty_id t a, ty_id t i, ty_id t v) 87 | | Epartial (f, e) -> Epartial (ty_id t f, ty_idl t e) 88 | 89 | and fields t l = List.map (field t) l 90 | and field t (fd, e) = fd, ty_idl t e 91 | 92 | and actions t l = List.map (action t) l 93 | and action t (p, e) = pat t p, expr t e 94 | 95 | and pat t pel = List.map (pat_el t) pel 96 | and pat_el t (ty, p) = ty, pat_ t p 97 | and pat_ t = function 98 | | Pany -> Pany 99 | | Pid x -> Pid (id t x) 100 | | Pvariant (x, p) -> Pvariant (x, pat t p) 101 | | Precord (x, pfl) -> 102 | let x = match x with None -> None | Some x -> Some (id t x) in 103 | let pfl = List.map (pfield t) pfl in 104 | Precord (x, pfl) 105 | | Pas (x, pel) -> Pas (id t x, pat_el t pel) 106 | 107 | and pfield t (x, p) = x, pat t p 108 | -------------------------------------------------------------------------------- /compiler/extractFuns.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | (* module transforming anonymous functions into partial applications *) 33 | 34 | open Utils 35 | open Ist 36 | 37 | module FreeVars = struct 38 | 39 | let rec pat fv ptl = 40 | List.fold_left pat_tuple fv ptl 41 | 42 | and pat_tuple fv pel = List.fold_left pat_el fv pel 43 | and pat_el fv (ty, pe) = pat_ fv ty pe 44 | and pat_ fv ty = function 45 | | Pany -> fv 46 | | Pid x -> IMap.remove x fv 47 | | Pvalue _ -> fv 48 | | Pvariant (_, p) -> pat fv p 49 | | Precord pfl -> List.fold_left pat_field fv pfl 50 | | Pas (x, p) -> 51 | let fv = pat fv p in 52 | IMap.remove x fv 53 | 54 | and pat_field fv = function 55 | | PFany -> fv 56 | | PFid x -> IMap.remove x fv 57 | | PField (_, p) -> pat fv p 58 | 59 | and tuple fv el = List.fold_left expr fv el 60 | and expr fv (ty, e) = expr_ fv ty e 61 | and expr_ fv ty = function 62 | | Eid x as v -> IMap.add x (ty, v) fv 63 | | Evalue _ -> fv 64 | | Evariant (id, t) -> 65 | let fv = tuple fv t in 66 | fv 67 | | Ebinop (_, e1, e2) -> 68 | let fv = expr fv e1 in 69 | let fv = expr fv e2 in 70 | fv 71 | | Euop (_, e1) -> 72 | let fv = expr fv e1 in 73 | fv 74 | | Erecord fdl -> 75 | fields fv fdl 76 | | Ewith (e, fdl) -> 77 | let fv = expr fv e in 78 | let fv = fields fv fdl in 79 | fv 80 | | Efield (e, id) -> 81 | let fv = expr fv e in 82 | fv 83 | | Ematch (t, al) -> 84 | let fv = tuple fv t in 85 | let fv = actions fv al in 86 | fv 87 | | Elet (p, t1, t2) -> 88 | let fv = tuple fv t1 in 89 | let fv = tuple fv t2 in 90 | let fv = pat fv p in 91 | fv 92 | | Eif (e, t1, t2) -> 93 | let fv = expr fv e in 94 | let fv = tuple fv t1 in 95 | let fv = tuple fv t2 in 96 | fv 97 | | Eapply (_, _, _, _, t) -> 98 | let fv = tuple fv t in 99 | fv 100 | | Eseq (e, t) -> 101 | let fv = expr fv e in 102 | let fv = tuple fv t in 103 | fv 104 | | Efree _ -> fv 105 | | Eset (e1, e2, e3) -> 106 | let fv = expr fv e1 in 107 | let fv = expr fv e2 in 108 | let fv = expr fv e3 in 109 | fv 110 | | Eget (e1, e2) -> 111 | let fv = expr fv e1 in 112 | let fv = expr fv e2 in 113 | fv 114 | | Eswap (e1, e2, e3) -> 115 | let fv = expr fv e1 in 116 | let fv = expr fv e2 in 117 | let fv = expr fv e3 in 118 | fv 119 | | Epartial (e, t) -> 120 | let fv = expr fv e in 121 | let fv = tuple fv t in 122 | fv 123 | | Efun (k, pel, t) -> 124 | let t = tuple fv t in 125 | pat_tuple t pel 126 | 127 | and fields x y = List.fold_left field x y 128 | and field fv (_, t) = tuple fv t 129 | and actions x y = List.fold_left action x y 130 | and action fv (p, t) = 131 | let fv = tuple fv t in 132 | pat fv p 133 | 134 | end 135 | 136 | let rec program mdl = 137 | List.rev_map module_ mdl 138 | 139 | and module_ md = 140 | let funs = md.md_decls, [] in 141 | let decls, defs = List.fold_left def funs md.md_defs in 142 | { md with md_decls = decls ; md_defs = defs } 143 | 144 | and def (decls, defs) (k, x, p, e) = 145 | let (decls, defs), e = tuple (decls, defs) e in 146 | let defs = (k, x, p, e) :: defs in 147 | decls, defs 148 | 149 | and tuple funs el = lfold expr funs el 150 | 151 | and expr funs (ty, e) = 152 | let funs, e = expr_ funs ty e in 153 | funs, (ty, e) 154 | 155 | and expr_ funs ty = function 156 | | Eid _ 157 | | Evalue _ as x -> funs, x 158 | | Evariant (x, t) -> 159 | let funs, t = tuple funs t in 160 | funs, Evariant (x, t) 161 | | Ebinop (op, e1, e2) -> 162 | let funs, e1 = expr funs e1 in 163 | let funs, e2 = expr funs e2 in 164 | funs, Ebinop (op, e1, e2) 165 | | Euop (op, e1) -> 166 | let funs, e1 = expr funs e1 in 167 | funs, Euop (op, e1) 168 | | Erecord fdl -> 169 | let funs, fdl = lfold field funs fdl in 170 | funs, Erecord fdl 171 | | Ewith (e, fdl) -> 172 | let funs, e = expr funs e in 173 | let funs, fdl = lfold field funs fdl in 174 | funs, Ewith (e, fdl) 175 | | Efield (e, id) -> 176 | let funs, e = expr funs e in 177 | funs, Efield (e, id) 178 | | Ematch (t, al) -> 179 | let funs, t = tuple funs t in 180 | let funs, al = lfold action funs al in 181 | funs, Ematch (t, al) 182 | | Elet (p, t1, t2) -> 183 | let funs, t1 = tuple funs t1 in 184 | let funs, t2 = tuple funs t2 in 185 | funs, Elet (p, t1, t2) 186 | | Eif (e, t1, t2) -> 187 | let funs, e = expr funs e in 188 | let funs, t1 = tuple funs t1 in 189 | let funs, t2 = tuple funs t2 in 190 | funs, Eif (e, t1, t2) 191 | | Eapply (b, k, ty, x, t) -> 192 | let funs, t = tuple funs t in 193 | funs, Eapply (b, k, ty, x, t) 194 | | Eseq (e, t) -> 195 | let funs, e = expr funs e in 196 | let funs, t = tuple funs t in 197 | funs, Eseq (e, t) 198 | | Efree _ as x -> funs, x 199 | | Eset (e1, e2, e3) -> 200 | let funs, e1 = expr funs e1 in 201 | let funs, e2 = expr funs e2 in 202 | let funs, e3 = expr funs e3 in 203 | funs, Eset (e1, e2, e3) 204 | | Eget (e1, e2) -> 205 | let funs, e1 = expr funs e1 in 206 | let funs, e2 = expr funs e2 in 207 | funs, Eget (e1, e2) 208 | | Eswap (e1, e2, e3) -> 209 | let funs, e1 = expr funs e1 in 210 | let funs, e2 = expr funs e2 in 211 | let funs, e3 = expr funs e3 in 212 | funs, Eswap (e1, e2, e3) 213 | | Epartial (e, t) -> 214 | let funs, e = expr funs e in 215 | let funs, t = tuple funs t in 216 | funs, Epartial (e, t) 217 | | Efun (k, pel, t) as e -> 218 | let fv = FreeVars.expr_ IMap.empty ty e in 219 | let fvl = IMap.fold (fun _ v y -> v :: y) fv [] in 220 | let pel = List.fold_right make_arg fvl pel in 221 | match fvl with 222 | | [] -> make_fun funs ty k pel t 223 | | args -> partial funs ty k pel t args 224 | 225 | and make_arg (tyl, e) acc = 226 | match tyl, e with 227 | | [ty], Eid x -> (ty, Pid x) :: acc 228 | | _ -> assert false 229 | 230 | and field funs (p, t) = 231 | let funs, t = tuple funs t in 232 | funs, (p, t) 233 | 234 | and action funs (p, t) = 235 | let funs, t = tuple funs t in 236 | funs, (p, t) 237 | 238 | and make_fun (decls, defs) fty k pel t = 239 | let fty = List.hd fty in 240 | let fid = Ident.tmp() in 241 | let decl = Dval (Ast.Private, fid, fty, Ast.Ext_none) in 242 | let def = k, fid, [pel], t in 243 | let decls = decl :: decls in 244 | let defs = def :: defs in 245 | (decls, defs), Eid fid 246 | 247 | and partial funs fty k pel t args = 248 | let funs, f = make_fun funs fty k pel t in 249 | funs, Epartial ((fty, f), args) 250 | -------------------------------------------------------------------------------- /compiler/global.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | 33 | include GenGlobals 34 | let suffix = ".lml" 35 | let llc_opts = " -O3 -tailcallopt " 36 | let (@@) x l = (stdlibdir ^ x ^ suffix) :: l 37 | let stdlib = Filename.concat stdlibdir "libliml.lmli" 38 | let max_reg_return = 1 39 | -------------------------------------------------------------------------------- /compiler/id.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | 33 | module StringId = struct 34 | type t = string 35 | let compare = String.compare 36 | end 37 | 38 | module IdSet = Set.Make(StringId) 39 | 40 | type env = { 41 | mutable sigs: IdSet.t ; 42 | mutable cvars: IdSet.t ; 43 | } 44 | 45 | open Ast 46 | 47 | let rec program l = 48 | let env = { sigs = IdSet.empty ; cvars = IdSet.empty } in 49 | List.iter (handler env) l ; 50 | env 51 | 52 | and handler env (pl, hb) = 53 | List.iter (pat env) pl ; 54 | List.iter (handler_body env) hb 55 | 56 | and pat env = function 57 | | Var s 58 | | Neg s -> env.sigs <- IdSet.add s env.sigs 59 | 60 | and instruction env = function 61 | | Emit s_l -> List.iter (fun x -> env.sigs <- IdSet.add x env.sigs) s_l 62 | | Call s_l -> List.iter (fun x -> env.cvars <- IdSet.add x env.cvars) s_l 63 | 64 | and handler_body env (inst_l, case_l) = 65 | List.iter (instruction env) inst_l ; 66 | List.iter (case env) case_l 67 | 68 | and case env (pat_l, inst_l) = 69 | List.iter (pat env) pat_l ; 70 | List.iter (instruction env) inst_l 71 | 72 | 73 | module IdMap = Map.Make (StringId) 74 | module TraceId = Map.Make (struct type t = int let compare = (-) end) 75 | 76 | let naming id_set = 77 | let tab = ref IdMap.empty in 78 | let back_tab = ref TraceId.empty in 79 | let i = ref 0 in 80 | IdSet.iter 81 | (fun elt -> 82 | if not (IdMap.mem elt !tab) 83 | then 84 | (incr i ; 85 | tab := IdMap.add elt !i !tab ; 86 | back_tab := TraceId.add !i elt !back_tab)) 87 | id_set ; 88 | !tab 89 | -------------------------------------------------------------------------------- /compiler/ident.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | 33 | type t = int 34 | 35 | module IMap = Map.Make (struct 36 | type t = int 37 | let compare = (-) 38 | end) 39 | 40 | let foo = 0 41 | let counter = ref 1 42 | let trace = ref IMap.empty 43 | let origin = ref IMap.empty 44 | let origin_id = ref IMap.empty 45 | 46 | let make x = 47 | incr counter ; 48 | let res = !counter in 49 | trace := IMap.add res x !trace ; 50 | res 51 | 52 | let fresh x = 53 | incr counter ; 54 | let res = !counter in 55 | let name = IMap.find x !trace in 56 | trace := IMap.add res name !trace ; 57 | res 58 | 59 | let tmp () = 60 | incr counter ; 61 | let res = !counter in 62 | trace := IMap.add res ("__tmp"^string_of_int res) !trace ; 63 | res 64 | 65 | let compare x y = x - y 66 | 67 | let to_string x = 68 | let v = 69 | try IMap.find x !trace 70 | with Not_found -> "v"^string_of_int x 71 | in 72 | try 73 | let md_id = IMap.find x !origin in 74 | md_id ^ "." ^ v 75 | with Not_found -> v 76 | 77 | let no_origin x = 78 | origin := IMap.remove x !origin ; 79 | origin_id := IMap.remove x !origin_id 80 | 81 | let expand_name md x = 82 | let md_name = IMap.find md !trace in 83 | origin_id := IMap.add x md !origin_id ; 84 | origin := IMap.add x md_name !origin 85 | 86 | let debug x = 87 | try IMap.find x !trace^"["^string_of_int x^"]" 88 | with Not_found -> "v["^string_of_int x^"]" 89 | 90 | let print x = 91 | Printf.printf "%s\n" (debug x) 92 | 93 | let origin x = 94 | IMap.find x !origin 95 | 96 | let origin_id x = 97 | IMap.find x !origin_id 98 | 99 | let to_ustring x = 100 | let s = to_string x in 101 | match s with (* TODO make a table *) 102 | | "free" | "print" | "print_int" -> s 103 | | _ -> s ^ string_of_int x 104 | 105 | let full x = 106 | let v = 107 | try IMap.find x !trace 108 | with Not_found -> "v"^string_of_int x 109 | in 110 | let md = try origin x with Not_found -> "" in 111 | if md = "" 112 | then v 113 | else md ^ "_" ^ v 114 | 115 | let set_name x y = 116 | trace := IMap.add x y !trace 117 | 118 | -------------------------------------------------------------------------------- /compiler/ident.mli: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | 33 | type t 34 | 35 | val foo: t 36 | val make: string -> t 37 | val fresh: t -> t 38 | val tmp: unit -> t 39 | val compare: t -> t -> int 40 | val to_string: t -> string 41 | val debug: t -> string 42 | val print: t -> unit 43 | val expand_name: t -> t -> unit 44 | val origin: t -> string 45 | val origin_id: t -> t 46 | val to_ustring: t -> string 47 | val full: t -> string 48 | val set_name: t -> string -> unit 49 | val no_origin: t -> unit 50 | -------------------------------------------------------------------------------- /compiler/ids.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | 33 | 34 | type program = handler list 35 | 36 | and handler = (pat list) * handler_body 37 | 38 | and id = 39 | | Var of string 40 | | BCall of string 41 | 42 | and pat = 43 | | Id of id 44 | | Neg of id 45 | 46 | and instruction = 47 | | Emit of string list 48 | | VCall of string 49 | 50 | and handler_body = (instruction list) * (case list) 51 | 52 | and case = (pat list) * (instruction list) 53 | 54 | -------------------------------------------------------------------------------- /compiler/ist.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | 34 | type id = Ident.t 35 | type pstring = string 36 | 37 | type program = module_ list 38 | 39 | and module_ = { 40 | md_sig: bool; 41 | md_id: id ; 42 | md_decls: decl list ; 43 | md_defs: def list ; 44 | } 45 | 46 | and decl = 47 | | Dalgebric of tdef 48 | | Drecord of tdef 49 | | Dval of Ast.link * id * type_expr * Ast.extern_def 50 | 51 | and tdef = { 52 | td_id: id ; 53 | td_args: id list ; 54 | td_map: (id * type_expr_list) IMap.t 55 | } 56 | 57 | and type_expr = 58 | | Tany 59 | | Tprim of type_prim 60 | | Tvar of id 61 | | Tid of id 62 | | Tapply of id * type_expr_list 63 | | Tfun of Ast.fun_kind * type_expr_list * type_expr_list 64 | 65 | and type_expr_list = type_expr list 66 | 67 | and type_prim = Nast.type_prim = 68 | | Tunit 69 | | Tbool 70 | | Tchar 71 | | Tint 72 | | Tfloat 73 | | Tstring 74 | 75 | and def = Ast.fun_kind * id * pat * tuple 76 | 77 | and pat = pat_tuple list 78 | and pat_tuple = pat_el list 79 | and pat_el = type_expr * pat_ 80 | and pat_ = 81 | | Pany 82 | | Pid of id 83 | | Pvalue of value 84 | | Pvariant of id * pat 85 | | Precord of pat_field list 86 | | Pas of id * pat 87 | 88 | and pat_field = 89 | | PFany 90 | | PFid of id 91 | | PField of id * pat 92 | 93 | and tuple = expr list 94 | and expr = type_expr_list * expr_ 95 | and expr_ = 96 | | Eid of id 97 | | Evalue of value 98 | | Evariant of id * tuple 99 | | Ebinop of Ast.bop * expr * expr 100 | | Euop of Ast.uop * expr 101 | | Erecord of (id * tuple) list 102 | | Ewith of expr * (id * tuple) list 103 | | Efield of expr * id 104 | | Ematch of tuple * (pat * tuple) list 105 | | Elet of pat * tuple * tuple 106 | | Eif of expr * tuple * tuple 107 | | Eapply of bool * Ast.fun_kind * type_expr * id * tuple 108 | | Eseq of expr * tuple 109 | | Efree of type_expr * id 110 | | Eset of expr * expr * expr 111 | | Eget of expr * expr 112 | | Eswap of expr * expr * expr 113 | | Epartial of expr * tuple 114 | | Efun of Ast.fun_kind * pat_el list * tuple 115 | 116 | and value = 117 | | Eunit 118 | | Ebool of bool 119 | | Eint of pstring 120 | | Efloat of pstring 121 | | Echar of pstring 122 | | Estring of pstring 123 | -------------------------------------------------------------------------------- /compiler/istOfStast.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | open Stast 34 | 35 | let id (_, x) = x 36 | let pstring (_, x) = x 37 | 38 | let rec program bounds mdl = 39 | List.rev_map (module_ bounds) mdl 40 | 41 | and module_ bounds md = { 42 | Ist.md_sig = md.md_sig ; 43 | Ist.md_id = id md.md_id ; 44 | Ist.md_decls = List.map decl md.md_decls ; 45 | Ist.md_defs = List.map (def bounds) md.md_defs ; 46 | } 47 | 48 | and decl = function 49 | | Dalgebric x -> Ist.Dalgebric (tdef x) 50 | | Drecord x -> Ist.Drecord (tdef x) 51 | | Dval (ll, x, y, v) -> Ist.Dval (ll, id x, type_expr y, v) 52 | 53 | and tdef td = { 54 | Ist.td_id = id td.td_id ; 55 | Ist.td_args = List.map id td.td_args ; 56 | Ist.td_map = IMap.map tfield td.td_map ; 57 | } 58 | 59 | and tfield (x, tyl) = id x, type_expr_list tyl 60 | 61 | and type_expr (_, ty) = 62 | match ty with 63 | | Tany -> Ist.Tany 64 | | Tprim x -> Ist.Tprim x 65 | | Tvar x -> Ist.Tvar (id x) 66 | | Tid x -> Ist.Tid (id x) 67 | | Tapply (x, tyl) -> Ist.Tapply (id x, type_expr_list tyl) 68 | | Tfun (k, tyl1, tyl2) -> 69 | let tyl1 = type_expr_list tyl1 in 70 | let tyl2 = type_expr_list tyl2 in 71 | Ist.Tfun (k, tyl1, tyl2) 72 | 73 | and type_expr_list (_, tyl) = List.map type_expr tyl 74 | 75 | and def bounds (k, x, p, e) = k, id x, pat p, tuple bounds e 76 | 77 | and pat (_, ptl) = List.map pat_tuple ptl 78 | and pat_tuple (_, pel) = List.map pat_el pel 79 | and pat_el (ty, p) = type_expr ty, pat_ p 80 | and pat_ = function 81 | | Pany -> Ist.Pany 82 | | Pid x -> Ist.Pid (id x) 83 | | Pvalue x -> Ist.Pvalue (value x) 84 | | Pvariant (x, p) -> Ist.Pvariant (id x, pat p) 85 | | Precord x -> Ist.Precord (List.map pat_field x) 86 | | Pas (x, p) -> Ist.Pas (id x, pat p) 87 | 88 | and pat_field (_, pf) = 89 | match pf with 90 | | PFany -> Ist.PFany 91 | | PFid x -> Ist.PFid (id x) 92 | | PField (x, p) -> Ist.PField (id x, pat p) 93 | 94 | and tuple bds (_, tpl) = List.map (tuple_pos bds) tpl 95 | and tuple_pos bds (tyl, e) = type_expr_list tyl, expr_ bds (fst tyl) e 96 | and expr bds (ty, e) = [type_expr ty], expr_ bds (fst ty) e 97 | 98 | and expr_ bds p = function 99 | | Eid x -> Ist.Eid (id x) 100 | | Evalue x -> Ist.Evalue (value x) 101 | | Evariant (x, e) -> Ist.Evariant (id x, (tuple bds e)) 102 | | Ebinop (x, e1, e2) -> Ist.Ebinop (x, expr bds e1, expr bds e2) 103 | | Euop (x, e) -> Ist.Euop (x, expr bds e) 104 | | Erecord fdl -> Ist.Erecord (List.map (field bds) fdl) 105 | | Ewith (e, fdl) -> Ist.Ewith (expr bds e, List.map (field bds) fdl) 106 | | Efield (e, x) -> Ist.Efield (expr bds e, id x) 107 | | Ematch (e, al) -> Ist.Ematch ((tuple bds e), List.map (action bds) al) 108 | | Elet (p, e1, e2) -> Ist.Elet (pat p, (tuple bds e1), (tuple bds e2)) 109 | | Eif (e1, e2, e3) -> Ist.Eif (expr bds e1, (tuple bds e2), (tuple bds e3)) 110 | | Eapply (fk, fty, x, e) -> 111 | let e = (tuple bds e) in 112 | let fid = snd x in 113 | if fid = Naming.aset 114 | then aset bds p e 115 | else if fid = Naming.aget 116 | then aget bds p e 117 | else if fid = Naming.aswap 118 | then aswap bds p e 119 | else if fid = Naming.alength 120 | then snd (alength e) 121 | else Ist.Eapply (false, fk, type_expr fty, id x, e) 122 | | Eseq (e1, e2) -> Ist.Eseq (expr bds e1, (tuple bds e2)) 123 | | Eobs x -> Ist.Eid (id x) 124 | | Efree (ty, x) -> Ist.Efree (type_expr ty, id x) 125 | | Epartial (f, e) -> Ist.Epartial (expr bds f, tuple bds e) 126 | | Efun (k, _, pl, e) -> 127 | let pl = List.map pat_el pl in 128 | let e = tuple bds e in 129 | Ist.Efun (k, pl, e) 130 | 131 | and field bds (x, e) = id x, (tuple bds e) 132 | and action bds (p, e) = pat p, (tuple bds e) 133 | 134 | and if_low i v1 v2 = 135 | let z = [Ist.Tprim Tint], Ist.Evalue (Ist.Eint "0") in 136 | let b = [Ist.Tprim Tbool], Ist.Ebinop (Ast.Elt, i, z) in 137 | let ty = List.flatten (List.map fst v2) in 138 | ty, Ist.Eif (b, v2, v1) 139 | 140 | and if_up i x v1 v2 = 141 | let b = [Ist.Tprim Tbool], Ist.Ebinop (Ast.Elt, i, x) in 142 | let ty = List.flatten (List.map fst v1) in 143 | ty, Ist.Eif (b, v1, v2) 144 | 145 | and alength t = length (List.hd t) 146 | and length t = 147 | let z = [Ist.Tprim Tint], Ist.Evalue (Ist.Eint "-1") in 148 | [Ist.Tprim Tint], Ist.Eget (t, z) 149 | 150 | and default ty = 151 | [ty], match ty with 152 | | Ist.Tprim ty -> 153 | let d = match ty with 154 | | Tunit -> Ist.Eunit 155 | | Tbool -> Ist.Ebool false 156 | | Tchar -> Ist.Echar "\000" 157 | | Tint -> Ist.Eint "0" 158 | | Tfloat -> Ist.Efloat "0.0" 159 | | Tstring -> Ist.Estring "" in 160 | Ist.Evalue d 161 | | _ -> assert false 162 | 163 | and aset bds p = function 164 | | [t ; i ; v] -> 165 | let low, up = get_bounds p bds in 166 | let ty = fst t in 167 | let e = ty, Ist.Eset (t, i, v) in 168 | let e = if low then if_low i [e] [t] else e in 169 | let e = if up then if_up i (length t) [e] [t] else e in 170 | snd e 171 | | _ -> assert false 172 | 173 | and aget bds p = function 174 | | [t ; i] -> 175 | let low, up = get_bounds p bds in 176 | let ty = match fst t with 177 | | [Ist.Tapply (_, [Ist.Tapply (_, [ty])])] -> ty 178 | | _ -> assert false in 179 | let e = [ty], Ist.Eget (t, i) in 180 | let e = if low then if_low i [e] [default ty] else e in 181 | let e = if up then if_up i (length t) [e] [default ty] else e in 182 | snd e 183 | | _ -> assert false 184 | 185 | and aswap bds p = function 186 | | [t ; i ; v] -> 187 | let low, up = get_bounds p bds in 188 | let ty = List.flatten (List.map fst [t;v]) in 189 | let e = ty, Ist.Eswap (t, i, v) in 190 | let e = if low then if_low i [e] [t; v] else e in 191 | let e = if up then if_up i (length t) [e] [t; v] else e in 192 | snd e 193 | | _ -> assert false 194 | 195 | and get_bounds p bds = 196 | try BoundCheck.PMap.find p bds 197 | with Not_found -> false, false 198 | 199 | and value = function 200 | | Eunit -> Ist.Eunit 201 | | Ebool x -> Ist.Ebool x 202 | | Eint x -> Ist.Eint (pstring x) 203 | | Efloat x -> Ist.Efloat (pstring x) 204 | | Echar x -> Ist.Echar (pstring x) 205 | | Estring x -> Ist.Estring (pstring x) 206 | 207 | -------------------------------------------------------------------------------- /compiler/istOptim.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | open Ist 34 | 35 | module Value = struct 36 | 37 | type t = 38 | | U 39 | | V of Ident.t 40 | | Sum of t list IMap.t 41 | | Rec of t * t list IMap.t 42 | 43 | let rec unify t1 t2 = 44 | match t1, t2 with 45 | | V x, V y when x = y -> V x 46 | | Sum m1, Sum m2 -> Sum (imap2 unify_list m1 m2) 47 | | Rec (r1, m1), Rec (r2, m2) -> 48 | let m = imap2 unify_list m1 m2 in 49 | Rec (unify r1 r2, m) 50 | | _ -> U 51 | 52 | and unify_list t1 t2 = 53 | List.map2 unify t1 t2 54 | 55 | let debug = function 56 | | U -> o "U" 57 | | V x -> o (Ident.debug x) 58 | | Sum _ -> o "Sum" 59 | | Rec _ -> o "Rec" 60 | 61 | end 62 | 63 | module Call = struct 64 | 65 | type t = Ident.t * Value.t list 66 | 67 | let compare = Pervasives.compare 68 | end 69 | 70 | module Analyse = struct 71 | open Value 72 | 73 | module CMap = Map.Make(Call) 74 | 75 | type env = { 76 | vals: Value.t IMap.t ; 77 | mem: Value.t list CMap.t ref ; 78 | defs: def IMap.t ; 79 | } 80 | 81 | let add_val x v env = 82 | { env with vals = IMap.add x v env.vals } 83 | 84 | let type_expr _ = V (Ident.tmp()) 85 | let type_expr_list tyl = List.map type_expr tyl 86 | 87 | let rec def env (_, _, p, e) = 88 | let tyl = List.fold_right (fun x acc -> fst x :: acc) (List.hd p) [] in 89 | let vl = type_expr_list tyl in 90 | List.iter (fun x -> debug x ; o ", ") vl ; 91 | print_newline() ; 92 | let env = pat env p vl in 93 | let e = tuple env e in 94 | List.iter (fun x -> debug x ; o ", ") e ; 95 | print_newline() ; 96 | e 97 | 98 | and pat env ptl vl = 99 | match ptl with 100 | | [l] -> pat_tuple env l vl 101 | | _ -> env 102 | 103 | and pat_tuple env pel vl = 104 | List.fold_left2 pat_el env pel vl 105 | 106 | and pat_el env (_, p) v = pat_ env p v 107 | and pat_ env p v = 108 | match p with 109 | | Pany -> env 110 | | Pid x -> add_val x v env 111 | | Pvalue _ -> env 112 | | Pvariant (x, p) -> 113 | (try match v with 114 | | Sum m -> pat env p (IMap.find x m) 115 | | _ -> env 116 | with Not_found -> env) 117 | | Precord pfl -> 118 | (match v with 119 | | Rec (_, m) -> List.fold_left (pat_field m v) env pfl 120 | | _ -> env) 121 | | Pas (x, p) -> 122 | let env = add_val x v env in 123 | pat env p [v] 124 | 125 | and pat_field m v env = function 126 | | PFany -> env 127 | | PFid x -> add_val x v env 128 | | PField (fd, p) -> 129 | (try pat env p (IMap.find fd m) 130 | with Not_found -> env) 131 | 132 | and tuple env el = 133 | List.fold_right ( 134 | fun e acc -> expr env e @ acc 135 | ) el [] 136 | 137 | and expr env (_, e) = expr_ env e 138 | and expr_ env = function 139 | | Eid x -> [try IMap.find x env.vals with Not_found -> U] 140 | | Evalue v -> [U] 141 | | Evariant (x, e) -> 142 | let e = tuple env e in 143 | [Sum (IMap.add x e IMap.empty)] 144 | | Ebinop _ -> [U] 145 | | Euop _ -> [U] 146 | | Erecord fdl -> 147 | let fdm = List.fold_left (field env) IMap.empty fdl in 148 | [Rec (V (Ident.tmp()) , fdm)] 149 | | Ewith (x, fdl) -> 150 | let fdm = List.fold_left (field env) IMap.empty fdl in 151 | let r = List.hd (expr env x) in 152 | [Rec (r, fdm)] 153 | | Efield (e, x) -> 154 | (match expr env e with 155 | | [Rec (_, m)] -> (try IMap.find x m with Not_found -> [U]) 156 | | _ -> [U]) 157 | | Ematch (e, al) -> 158 | let e = tuple env e in 159 | let al = List.map (action env e) al in 160 | (match al with 161 | | [] -> assert false 162 | | [x] -> x 163 | | x :: rl -> List.fold_left unify_list x rl) 164 | | Elet (p, e1, e2) -> 165 | let env = pat env p (tuple env e1) in 166 | tuple env e2 167 | | Eif (c, e1, e2) -> 168 | let _ = expr env c in 169 | unify_list (tuple env e1) (tuple env e2) 170 | | Eapply (_, _, f, e) when f = Naming.aset -> 171 | let e = tuple env e in 172 | (match e with 173 | | [t ; _ ; _] -> [t] 174 | | _ -> [U]) 175 | | Eapply (_, fty, f, e) -> 176 | let e = tuple env e in 177 | (try CMap.find (f, e) !(env.mem) 178 | with Not_found -> 179 | (match fty with 180 | | Tfun (_, _, tyl) -> 181 | let vl = type_expr_list tyl in 182 | (try 183 | env.mem := CMap.add (f, e) vl !(env.mem) ; 184 | let _, _, args, body = IMap.find f env.defs in 185 | let env = pat env args e in 186 | let vl = tuple env body in 187 | env.mem := CMap.add (f, e) vl !(env.mem); 188 | vl 189 | with Not_found -> vl) 190 | | _ -> assert false)) 191 | | Eseq (e1, e2) -> 192 | let _ = expr env e1 in 193 | tuple env e2 194 | | Efree _ -> [U] 195 | 196 | and field env m (x, e) = 197 | let e = tuple env e in 198 | IMap.add x e m 199 | 200 | and action env vl (p, e) = 201 | let env = pat env p vl in 202 | tuple env e 203 | 204 | end 205 | 206 | open Analyse 207 | 208 | let rec program mdl = 209 | List.iter module_ mdl 210 | 211 | and module_ md = 212 | let defs = List.fold_left ( 213 | fun acc ((_, x, _, _) as df) -> IMap.add x df acc 214 | ) IMap.empty md.md_defs in 215 | let env = { vals = IMap.empty; mem = ref CMap.empty ; defs = defs } in 216 | List.iter (fun x -> ignore (Analyse.def env x)) md.md_defs 217 | -------------------------------------------------------------------------------- /compiler/istRecords.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | open Ist 34 | 35 | let alias subst e = 36 | IMap.fold ( 37 | fun x ((ty, _) as y) acc -> 38 | let rty = fst (List.hd acc) in 39 | [rty, Elet ([[List.hd ty, Pid x]], [y], acc)] 40 | ) subst e 41 | 42 | 43 | let rec program p = 44 | List.rev_map module_ p 45 | 46 | and module_ md = 47 | let defs = List.map def md.md_defs in 48 | let md = { md with md_defs = defs } in 49 | md 50 | 51 | and def (k, x, p, e) = 52 | let subst, p = pat IMap.empty p in 53 | let e = tuple e in 54 | let e = alias subst e in 55 | (k, x, p, e) 56 | 57 | and pat acc ptl = 58 | let acc, ptl = lfold pat_tuple acc ptl in 59 | acc, ptl 60 | 61 | and pat_tuple acc pel = 62 | let acc, pel = lfold pat_el acc pel in 63 | acc, pel 64 | 65 | and pat_el acc (ty, p) = 66 | let acc, p = pat_ acc ty p in 67 | acc, (ty, p) 68 | 69 | and pat_ acc ty = function 70 | | Pany | Pid _ 71 | | Pvalue _ as x -> acc, x 72 | | Pvariant (x, p) -> 73 | let acc, p = pat acc p in 74 | acc, Pvariant (x, p) 75 | | Precord pfl -> 76 | let rid = record_id pfl in 77 | let rexpr = [ty], Eid rid in 78 | let acc = List.fold_left (pat_field rexpr) acc pfl in 79 | acc, Pid rid 80 | | Pas (x, p) -> 81 | let acc, p = pat acc p in 82 | acc, Pas (x, p) 83 | 84 | and record_id = function 85 | | [] -> Ident.tmp() 86 | | PFid x :: _ -> x 87 | | _ :: rl -> record_id rl 88 | 89 | and pat_field rid acc = function 90 | | PFany 91 | | PFid _ 92 | | PField (_, [[_, Pany]]) -> acc 93 | | PField (x, [l]) -> List.fold_left (make_field rid x) acc l 94 | | _ -> assert false 95 | 96 | and make_field rid x acc p = 97 | match p with 98 | | _, Pid y -> 99 | let v = fst rid, Efield (rid, x) in 100 | IMap.add y v acc 101 | | _ -> assert false 102 | 103 | and tuple l = List.map expr l 104 | and expr (ty, e) = ty, expr_ ty e 105 | and expr_ ty = function 106 | | Eid _ 107 | | Efree _ 108 | | Evalue _ as e -> e 109 | | Evariant (x, e) -> 110 | let e = tuple e in 111 | Evariant (x, e) 112 | | Ebinop (bop, e1, e2) -> 113 | let e1 = expr e1 in 114 | let e2 = expr e2 in 115 | Ebinop (bop, e1, e2) 116 | | Euop (uop, e) -> 117 | let e = expr e in 118 | Euop (uop, e) 119 | | Erecord fdl -> 120 | let fdl = List.map field fdl in 121 | Erecord fdl 122 | | Ewith (e, fdl) -> 123 | let fdl = List.map field fdl in 124 | let e = expr e in 125 | Ewith (e, fdl) 126 | | Efield (e, x) -> 127 | let e = expr e in 128 | Efield (e, x) 129 | | Ematch (e, al) -> 130 | let e = tuple e in 131 | let al = List.map action al in 132 | Ematch (e, al) 133 | | Elet (p, e1, e2) -> 134 | let subst, p = pat IMap.empty p in 135 | let e1 = tuple e1 in 136 | let e2 = tuple e2 in 137 | let e = Elet (p, e1, e2) in 138 | let e = alias subst [ty, e] in 139 | snd (List.hd e) 140 | | Eif (c, e1, e2) -> 141 | let c = expr c in 142 | let e1 = tuple e1 in 143 | let e2 = tuple e2 in 144 | Eif (c, e1, e2) 145 | | Eapply (fk, ty, x, e) -> 146 | let e = tuple e in 147 | Eapply (fk, ty, x, e) 148 | | Eseq (e1, e2) -> 149 | let e1 = expr e1 in 150 | let e2 = tuple e2 in 151 | Eseq (e1, e2) 152 | 153 | and field (x, e) = 154 | let e = tuple e in 155 | (x, e) 156 | 157 | and action (p, a) = 158 | let subst, p = pat IMap.empty p in 159 | let a = tuple a in 160 | let a = alias subst a in 161 | (p, a) 162 | -------------------------------------------------------------------------------- /compiler/istTail.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | open Ist 34 | 35 | let rec program mdl = 36 | List.map module_ mdl 37 | 38 | and module_ md = 39 | { md with md_defs = List.map def md.md_defs } 40 | 41 | and def (k, x, p, t) = 42 | (k, x, p, tuple t) 43 | 44 | and tuple el = 45 | match el with 46 | | [e] -> [expr e] 47 | | l -> l 48 | 49 | and expr (tyl, e) = tyl, expr_ e 50 | 51 | and expr_ = function 52 | | Ematch (e, al) -> Ematch (e, List.map action al) 53 | | Elet (p, e1, e2) -> Elet (p, e1, tuple e2) 54 | | Eif (c, e1, e2) -> Eif (c, tuple e1, tuple e2) 55 | | Eapply (_, k, ty, x, e) -> Eapply (true, k, ty, x, e) 56 | | e -> e 57 | 58 | and action (p, e) = p, tuple e 59 | -------------------------------------------------------------------------------- /compiler/llst.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | 34 | type id = Ident.t 35 | type label = Ident.t 36 | type pstring = string 37 | 38 | type program = module_ list 39 | 40 | and module_ = { 41 | md_sig: bool; 42 | md_id: id ; 43 | md_decls: decl list ; 44 | md_defs: def list ; 45 | } 46 | 47 | and decl = 48 | | Dtype of id * type_expr 49 | | Dval of Ast.link * id * type_expr * Ast.extern_def 50 | 51 | and type_expr = 52 | | Tany 53 | | Tprim of type_prim 54 | | Tid of id 55 | | Tfun of Ast.fun_kind * type_expr_list * type_expr_list 56 | | Tstruct of type_expr list 57 | | Tptr of type_expr 58 | 59 | and type_expr_list = type_expr list 60 | 61 | and type_prim = Nast.type_prim = 62 | | Tunit 63 | | Tbool 64 | | Tchar 65 | | Tint 66 | | Tfloat 67 | | Tstring 68 | 69 | and ty_id = type_expr * id 70 | and ty_idl = ty_id list 71 | 72 | and def = { 73 | df_id: id ; 74 | df_kind: Ast.fun_kind ; 75 | df_args: ty_id list ; 76 | df_body: block list ; 77 | df_ret: type_expr list ; 78 | } 79 | 80 | and block = { 81 | bl_id: label ; 82 | bl_phi: phi list ; 83 | bl_eqs: equation list ; 84 | bl_ret: ret ; 85 | } 86 | 87 | and ret = 88 | | Return of bool * ty_idl 89 | | Jump of label 90 | | If of ty_id * label * label 91 | | Switch of ty_id * (value * label) list * label 92 | 93 | and phi = id * type_expr * (id * label) list 94 | 95 | and equation = ty_idl * expr 96 | 97 | and expr = 98 | | Enull 99 | | Eid of ty_id 100 | | Evalue of value 101 | | Ebinop of Ast.bop * ty_id * ty_id 102 | | Euop of Ast.uop * ty_id 103 | | Efield of ty_id * int 104 | | Eapply of bool * Ast.fun_kind * bool * ty_id * ty_idl 105 | | Etuple of ty_id option * (int * ty_id) list 106 | | Egettag of ty_id 107 | | Eproj of ty_id * int 108 | | Eptr_of_int of Ident.t 109 | | Eint_of_ptr of Ident.t 110 | | Eis_null of ty_id 111 | | Efree of ty_id 112 | | Eget of ty_id * ty_id 113 | | Eset of ty_id * ty_id * ty_id 114 | | Eswap of ty_id * ty_id * ty_id 115 | | Epartial of ty_id * ty_idl 116 | 117 | and value = 118 | | Eunit 119 | | Ebool of bool 120 | | Eint of pstring 121 | | Efloat of pstring 122 | | Echar of pstring 123 | | Estring of pstring 124 | | Eiint of int 125 | -------------------------------------------------------------------------------- /compiler/llstFree.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | 34 | 35 | module Usage = struct 36 | open Llst 37 | 38 | let ty_id acc (_, x) = ISet.add x acc 39 | let ty_idl acc l = List.fold_left ty_id acc l 40 | 41 | let rec block bl = 42 | let acc = ISet.empty in 43 | let acc = List.fold_left phi acc bl.bl_phi in 44 | let acc = List.fold_left equation acc bl.bl_eqs in 45 | let acc = ret acc bl.bl_ret in 46 | acc 47 | 48 | and ret acc = function 49 | | Return (_, l) -> ty_idl acc l 50 | | Jump _ -> acc 51 | | Switch (x, _, _) 52 | | If (x, _, _) -> 53 | let acc = ty_id acc x in 54 | acc 55 | 56 | and phi acc (x, _, l) = 57 | let acc = ISet.add x acc in 58 | List.fold_left ( 59 | fun acc (x, _) -> ISet.add x acc 60 | ) acc l 61 | 62 | and equation acc (_, e) = 63 | let acc = expr acc e in 64 | acc 65 | 66 | and expr acc = function 67 | | Enull -> acc 68 | | Egettag x 69 | | Eproj (x, _) 70 | | Efree x 71 | | Eid x 72 | | Eis_null x -> ISet.add (snd x) acc 73 | | Eptr_of_int x 74 | | Eint_of_ptr x -> ISet.add x acc 75 | | Evalue _ -> acc 76 | | Eget (x1, x2) 77 | | Ebinop (_, x1, x2) -> 78 | let acc = ty_id acc x1 in 79 | let acc = ty_id acc x2 in 80 | acc 81 | | Eset (x1, x2, x3) 82 | | Eswap (x1, x2, x3) -> 83 | let acc = ty_id acc x1 in 84 | let acc = ty_id acc x2 in 85 | let acc = ty_id acc x3 in 86 | acc 87 | | Euop (_, x) -> ty_id acc x 88 | | Efield (x, _) -> ty_id acc x 89 | | Epartial (_, l) 90 | | Eapply (_, _, _, _, l) -> ty_idl acc l 91 | | Etuple (v, l) -> 92 | let acc = match v with None -> acc | Some v -> ty_id acc v in 93 | let acc = List.fold_left ( 94 | fun acc (_, x) -> ty_id acc x 95 | ) acc l in 96 | acc 97 | end 98 | 99 | open Llst 100 | 101 | type work = 102 | | Insert_free of Llst.label * Llst.ty_id 103 | | Remove_free of Llst.label * Llst.id 104 | 105 | let debug_todo todo = 106 | List.iter ( 107 | function 108 | | Remove_free (lbl, id) -> 109 | Printf.printf "Remove %s %s\n" (Ident.debug lbl) (Ident.debug id) 110 | | Insert_free (lbl, (_, id)) -> 111 | Printf.printf "Insert %s %s\n" (Ident.debug lbl) (Ident.debug id) 112 | ) todo 113 | 114 | let rec cont acc = function 115 | | Return _ -> acc 116 | | Jump lbl -> ISet.add lbl acc 117 | | If (_, lbl1, lbl2) -> ISet.add lbl1 (ISet.add lbl2 acc) 118 | | Switch (_, al, _) -> 119 | let acc = List.fold_left ( 120 | fun acc (_, lbl) -> ISet.add lbl acc 121 | ) acc al in 122 | acc 123 | 124 | (* TODO memoize *) 125 | let rec is_used bls usage x lbl = 126 | let bl = IMap.find lbl bls in 127 | let uses = IMap.find bl.bl_id usage in 128 | ISet.mem x uses || 129 | is_used_ret bls usage x bl 130 | 131 | and is_used_ret bls usage x bl = 132 | ISet.fold 133 | (fun lbl acc -> acc || is_used bls usage x lbl) 134 | (cont ISet.empty bl.bl_ret) 135 | false 136 | 137 | let is_branching bl = 138 | match bl.bl_ret with 139 | | If _ | Switch _ -> true 140 | | _ -> false 141 | 142 | (* TODO memoize ? *) 143 | let rec insert bls usage ((_, x) as id) acc lbl = 144 | if ISet.mem x (IMap.find lbl usage) 145 | then acc 146 | else 147 | (* In general it's better to push the frees within the branches *) 148 | (* TODO do this optimization properly *) 149 | let bl = IMap.find lbl bls in 150 | if is_branching bl || is_used bls usage x lbl 151 | then insert_ret bls usage id acc bl 152 | else Insert_free (lbl, id) :: acc 153 | 154 | and insert_ret bls usage x acc bl = 155 | ISet.fold 156 | (fun lbl acc -> insert bls usage x acc lbl) 157 | (cont ISet.empty bl.bl_ret) 158 | acc 159 | 160 | let rec program mdl = 161 | List.map module_ mdl 162 | 163 | and module_ md = 164 | { md with md_defs = List.map def md.md_defs } 165 | 166 | and def df = 167 | let bls = List.fold_left ( 168 | fun acc b -> IMap.add b.bl_id b acc 169 | ) IMap.empty df.df_body in 170 | let usages = List.fold_left ( 171 | fun acc b -> IMap.add b.bl_id (Usage.block b) acc 172 | ) IMap.empty df.df_body in 173 | let todo = List.fold_left (block_todo bls usages) [] df.df_body in 174 | let rmset = List.fold_left ( 175 | fun acc x -> 176 | match x with 177 | | Remove_free (_, x) -> ISet.add x acc 178 | | _ -> acc 179 | ) ISet.empty todo in 180 | let body = List.map (block_remove rmset) df.df_body in 181 | let ins = List.fold_left ( 182 | fun acc x -> 183 | match x with 184 | | Insert_free (lbl, x) -> 185 | let xs = try IMap.find lbl acc with Not_found -> IMap.empty in 186 | IMap.add lbl (IMap.add (snd x) x xs) acc 187 | | _ -> acc 188 | ) IMap.empty todo in 189 | let body = List.map (block_insert ins) body in 190 | { df with df_body = body } 191 | 192 | and block_todo bls usage acc bl = 193 | List.fold_left ( 194 | fun acc (_, e) -> 195 | match e with 196 | | Efree x -> 197 | if is_branching bl || is_used_ret bls usage (snd x) bl 198 | then 199 | let acc = Remove_free (bl.bl_id, snd x) :: acc in 200 | let acc = insert_ret bls usage x acc bl in 201 | acc 202 | else acc 203 | | _ -> acc 204 | ) acc bl.bl_eqs 205 | 206 | and block_remove rm_set bl = 207 | { bl with bl_eqs = List.filter ( 208 | fun (_, e) -> 209 | match e with 210 | | Efree (_, x) -> not (ISet.mem x rm_set) 211 | | _ -> true 212 | ) bl.bl_eqs } 213 | 214 | and block_insert ins bl = 215 | try 216 | let xl = IMap.find bl.bl_id ins in 217 | let eqs = IMap.fold (fun _ v acc -> 218 | let dummy = Llst.Tprim Tunit, Ident.tmp() in 219 | ([dummy], Llst.Efree v) :: acc) xl bl.bl_eqs in 220 | { bl with bl_eqs = eqs } 221 | with Not_found -> bl 222 | 223 | -------------------------------------------------------------------------------- /compiler/llstOptim.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | open Llst 34 | 35 | module Occ = struct 36 | 37 | let get x t = try IMap.find x t with Not_found -> 0 38 | 39 | let add x t = 40 | let n = get x t in 41 | let n = n+1 in 42 | IMap.add x n t 43 | 44 | let rec def df = 45 | let t = IMap.empty in 46 | List.fold_left block t df.df_body 47 | 48 | and block t bl = 49 | let t = List.fold_left phi t bl.bl_phi in 50 | let t = ret t bl.bl_ret in 51 | t 52 | 53 | and ret t = function 54 | | Return _ -> t 55 | | Jump lbl -> add lbl t 56 | | If (_, lbl1, lbl2) -> 57 | let t = add lbl1 t in 58 | let t = add lbl2 t in 59 | t 60 | | Switch (_, al, d) -> 61 | let t = add d t in 62 | let t = List.fold_left action t al in 63 | t 64 | 65 | and phi t (_, _, l) = 66 | List.fold_left phi_case t l 67 | 68 | and action t (_, lbl) = add lbl t 69 | and phi_case t (_, lbl) = add lbl t 70 | 71 | end 72 | 73 | 74 | 75 | module InlineBlocks = struct 76 | 77 | let rec program mdl = 78 | List.rev_map module_ mdl 79 | 80 | and module_ md = 81 | let defs = List.map def md.md_defs in 82 | { md with md_defs = defs } 83 | 84 | and def df = 85 | let t = Occ.def df in 86 | let bls = List.fold_left ( 87 | fun acc bl -> IMap.add bl.bl_id bl acc 88 | ) IMap.empty df.df_body in 89 | let suppr = ref ISet.empty in 90 | let bll = List.map (inline t bls suppr) df.df_body in 91 | if ISet.is_empty !suppr 92 | then df 93 | else 94 | let bll = List.filter (fun b -> not (ISet.mem b.bl_id !suppr)) bll in 95 | { df with df_body = bll } 96 | 97 | and inline t bls suppr bl = 98 | match bl.bl_ret with 99 | | Jump lbl when Occ.get lbl t = 1 && bl.bl_phi = [] -> 100 | let tail = IMap.find lbl bls in 101 | let eqs = bl.bl_eqs @ tail.bl_eqs in 102 | suppr := ISet.add tail.bl_id !suppr ; 103 | inline t bls suppr { bl with bl_eqs = eqs ; bl_ret = tail.bl_ret } 104 | | _ -> bl 105 | 106 | 107 | end 108 | 109 | module Type: sig 110 | 111 | type t 112 | type env 113 | 114 | val program: Llst.program -> env 115 | val type_expr: env -> Llst.type_expr -> t 116 | val compare: t -> t -> int 117 | 118 | end = struct 119 | 120 | type t = Llst.type_expr 121 | type env = Llst.type_expr IMap.t 122 | 123 | let rec program mdl = 124 | let t = IMap.empty in 125 | let t = List.fold_left module_decl t mdl in 126 | t 127 | 128 | and module_decl t md = 129 | List.fold_left decl_prim t md.md_decls 130 | 131 | and decl_prim t = function 132 | | Dtype (x, (Tprim _ as ty)) -> IMap.add x ty t 133 | | _ -> t 134 | 135 | and type_expr t = function 136 | | Tany 137 | | Tprim _ as x -> x 138 | | Tid x -> (try IMap.find x t with Not_found -> Tany) 139 | | Tfun _ -> Tany 140 | | Tstruct tyl -> Tstruct (List.map (type_expr t) tyl) 141 | | Tptr _ -> Tany 142 | 143 | let compare = Pervasives.compare 144 | 145 | end 146 | 147 | module Inplace = struct 148 | module Env = Map.Make (Type) 149 | 150 | let get ty env = 151 | try Env.find ty env with Not_found -> [] 152 | 153 | let push ty x env = 154 | let l = get ty env in 155 | let l = x :: l in 156 | Env.add ty l env 157 | 158 | let pop ty env = 159 | match get ty env with 160 | | [] -> env, None 161 | | x :: rl -> 162 | let env = Env.add ty rl env in 163 | env, Some x 164 | 165 | let rec program mdl = 166 | let t = Type.program mdl in 167 | List.map (module_ t) mdl 168 | 169 | and module_ t md = 170 | { md with md_defs = List.map (def t) md.md_defs } 171 | 172 | and def t df = 173 | { df with df_body = List.map (block t) df.df_body } 174 | 175 | and block t bl = 176 | let acc = (Env.empty, ISet.empty, []) in 177 | let _, dels, eqs = List.fold_left (equation t) acc bl.bl_eqs in 178 | let eqs = List.rev eqs in 179 | let eqs = List.filter (suppr_free dels) eqs in 180 | { bl with bl_eqs = eqs } 181 | 182 | and equation t (env, dels, eqs) ((idl, e) as eq) = 183 | match e with 184 | | Efree (ty, x) -> 185 | let ty = Type.type_expr t ty in 186 | let env = push ty x env in 187 | (env, dels, eq :: eqs) 188 | | Etuple (None, vl) -> 189 | (match idl with 190 | | [ty, x] -> 191 | let env, v = pop (Type.type_expr t ty) env in 192 | (match v with 193 | | None -> env, dels, eq :: eqs 194 | | Some vid -> 195 | let vid' = Ident.tmp() in 196 | let v = Some (ty, vid') in 197 | let eqs = ([ty, vid'], Eid (ty, vid)) :: eqs in 198 | let eqs = (idl, Etuple (v, vl)) :: eqs in 199 | let dels = ISet.add vid dels in 200 | (env, dels, eqs)) 201 | | _ -> assert false) 202 | | _ -> env, dels, eq :: eqs 203 | 204 | and suppr_free dels (_, e) = 205 | match e with 206 | | Efree (_, x) -> not (ISet.mem x dels) 207 | | _ -> true 208 | 209 | end 210 | 211 | module LoadStore = struct 212 | 213 | type value = 214 | | Id of Ident.t 215 | | Field of Ident.t * int 216 | 217 | let rec program mdl = 218 | let t = Type.program mdl in 219 | List.map (module_ t) mdl 220 | 221 | and module_ t md = 222 | { md with md_defs = List.map (def t) md.md_defs } 223 | 224 | and def t df = 225 | { df with df_body = List.map (block t) df.df_body } 226 | 227 | and block t bl = 228 | let acc = IMap.empty in 229 | let env, eqs = lfold (equation t) acc bl.bl_eqs in 230 | { bl with bl_eqs = eqs } 231 | 232 | and eqid = function [_, x] -> x | _ -> assert false 233 | 234 | and equation t env ((idl, e) as eq) = 235 | match e with 236 | | Eid (_, x) -> 237 | (try 238 | IMap.add (eqid idl) (IMap.find x env) env, eq 239 | with Not_found -> env, eq) 240 | | Eproj ((_, x), n) 241 | | Efield ((_, x), n) -> 242 | let v = eqid idl in 243 | IMap.add v (Field (x, n)) env, eq 244 | | Etuple (Some v, fdl) -> 245 | let rid = snd v in 246 | let fdl = List.filter (filter_field env rid) fdl in 247 | env, (idl, Etuple (Some v, fdl)) 248 | | _ -> env, eq 249 | 250 | and filter_field env rid (n, (_, v)) = 251 | try match IMap.find v env with 252 | | Field (r', n') -> not (r' = rid && n' = n) 253 | | _ -> true 254 | with Not_found -> true 255 | 256 | 257 | end 258 | 259 | let program mdl = 260 | let mdl = Inplace.program mdl in 261 | let mdl = LoadStore.program mdl in 262 | mdl 263 | 264 | let inline mdl = InlineBlocks.program mdl 265 | -------------------------------------------------------------------------------- /compiler/llstPp.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | open Llst 34 | 35 | let n = ref 0 36 | let space() = 37 | let rec aux n = if n = 0 then () else (o " " ; aux (n-1)) in 38 | aux !n 39 | 40 | let nl() = o "\n" ; space() 41 | 42 | let push() = n := !n + 2 43 | let pop() = n := !n - 2 44 | 45 | let id x = o (Ident.debug x) 46 | let label x = o (Ident.debug x) 47 | let pstring x = o x 48 | 49 | let rec program mdl = 50 | List.iter module_ mdl 51 | 52 | and module_ md = 53 | o "module " ; 54 | id md.md_id ; 55 | o ":" ; 56 | push() ; 57 | nl() ; 58 | nl() ; 59 | List.iter decl md.md_decls ; 60 | pop() ; 61 | nl() ; 62 | o "end" ; 63 | o " = struct" ; 64 | push() ; 65 | nl() ; 66 | List.iter def md.md_defs ; 67 | pop() ; 68 | nl() ; 69 | o "end" ; 70 | nl() 71 | 72 | and decl = function 73 | | Dtype (x, ty) -> 74 | o "type " ; id x ; o " = " ; type_expr ty ; 75 | nl () ; 76 | | Dval (ll, x, ty, v) -> 77 | o "val " ; 78 | (match ll with 79 | | Ast.Abstract -> assert false 80 | | Ast.Public -> () | Ast.Private -> o "private ") ; 81 | id x ; o ": " ; type_expr ty ; 82 | (match v with 83 | | Ast.Ext_none -> () 84 | | Ast.Ext_C x -> o " = " ; o (snd x) 85 | | Ast.Ext_Asm x -> o " = (asm)" ; o (snd x) 86 | | Ast.Ext_I -> o " = (internal)") ; 87 | nl () ; 88 | 89 | and type_expr = function 90 | | Tany -> o "void*" 91 | | Tprim tp -> type_prim tp 92 | | Tid x -> id x 93 | | Tptr x -> type_expr x ; o "*" 94 | | Tfun (k, tyl1, tyl2) -> 95 | o "(" ; 96 | type_expr_list tyl1 ; 97 | o (match k with Ast.Cfun -> " #" | Ast.Lfun -> " ") ; 98 | o "-> " ; 99 | type_expr_list tyl2 ; 100 | o ")" 101 | | Tstruct tyl -> 102 | o "{ " ; print_list o (fun _ x -> type_expr x) ", " tyl ; o " }" 103 | 104 | and type_expr_list l = 105 | if l = [] 106 | then o "void" 107 | else print_list o (fun _ x -> type_expr x) ", " l 108 | 109 | and type_prim = function 110 | | Tunit -> o "unit" 111 | | Tbool -> o "bool" 112 | | Tchar -> o "char" 113 | | Tint -> o "int" 114 | | Tfloat -> o "float" 115 | | Tstring -> o "string" 116 | 117 | and def df = 118 | id df.df_id ; 119 | o " " ; 120 | List.iter (fun (ty, x) -> o "(" ; id x ; o ": " ; type_expr ty ; o ") ") df.df_args ; 121 | o ": " ; type_expr_list df.df_ret ; 122 | o " = " ; 123 | push() ; 124 | List.iter block df.df_body ; 125 | pop() ; 126 | nl() ; nl() ; 127 | 128 | and idl l = o "(" ; print_list o (fun _ (_, x) -> id x) ", " l ; o ")" 129 | and ty_idl l = 130 | o "(" ; 131 | print_list o (fun _ (ty, x) -> type_expr ty ; o " " ; id x) ", " l; 132 | o ")" 133 | 134 | and block bl = 135 | nl() ; 136 | id bl.bl_id ; 137 | o ":" ; 138 | nl() ; 139 | push() ; 140 | nl() ; 141 | if bl.bl_phi <> [] then (o "phi: " ; nl() ; List.iter phi bl.bl_phi ; nl()) ; 142 | List.iter equation bl.bl_eqs ; 143 | (match bl.bl_ret with 144 | | Return (tail, l) -> 145 | (o "return[" ; 146 | o (if tail then "true] " else "false] ") ; 147 | ty_idl l) 148 | | Jump x -> o "jump " ; id x 149 | | If (x, l1, l2) -> 150 | o "Iif " ; tid x ; o " then jump " ; label l1 ; 151 | o " else jump " ; label l2 ; 152 | | Switch (x, al, default) -> 153 | o "switch " ; ty_id x ; push() ; nl() ; List.iter maction al ; pop() ; 154 | o "default: " ; id default ; 155 | ) ; 156 | pop() ; 157 | nl() 158 | 159 | and phi (x, ty, l) = 160 | id x ; o ":" ; type_expr ty ; o " <- " ; 161 | List.iter (fun (x, lbl) -> o "(" ; id x ; o ", " ; label lbl ; o ") ; ") l ; 162 | nl() 163 | 164 | and equation (idl, e) = 165 | print_list o (fun _ (ty, x) -> type_expr ty ; o " " ; id x) ", " idl ; 166 | o " = " ; 167 | expr e ; 168 | nl() 169 | 170 | and ty_id (ty, x) = o "(" ; o (Ident.debug x) ; o ":" ; type_expr ty ; o ") " 171 | 172 | and expr = function 173 | | Enull -> o "null" 174 | | Eis_null x -> o "null? " ; ty_id x 175 | | Eid x -> ty_id x 176 | | Evalue v -> value v 177 | | Ebinop (bop, id1, id2) -> binop bop ; o " " ; tid id1 ; o " " ; tid id2 178 | | Euop (uop, x) -> unop uop ; o " " ; tid x 179 | | Etuple (x, l) -> o "{ " ; maybe ty_id x ; o " | " ; 180 | print_list o (fun _ (n, x) -> o "[" ; o (soi n) ; o "]=" ; ty_id x) ", " l ; o " }" 181 | | Efield (x, y) -> tid x ; o "." ; o (soi y) 182 | | Eapply (_, fk, b, x, l) -> 183 | if b then o "tail " else () ; 184 | o "call[" ; 185 | (match fk with Ast.Cfun -> o "C] " | Ast.Lfun -> o "L] ") ; 186 | ty_id x ; o " " ; idl l 187 | | Egettag x -> o "gettag " ; tid x 188 | | Eproj (x, n) -> tid x ; o "[" ; o (soi n) ; o "]" 189 | | Eptr_of_int x -> o "(pointer) " ; id x 190 | | Eint_of_ptr x -> o "(int) " ; id x 191 | | Efree x -> o "free " ; id (snd x) 192 | | Eget (x, y) -> o "get " ; id (snd x) ; id (snd y) 193 | | Eset (x, y, z) -> o "set " ; id (snd x) ; id (snd y) ; id (snd z) 194 | | Eswap (x, y, z) -> o "swap " ; id (snd x) ; id (snd y) ; id (snd z) 195 | | Epartial (f, e) -> o "partial " ; id (snd f) ; ty_idl e 196 | 197 | and bounds l u = 198 | o "[" ; o (string_of_bool l) ; 199 | o "," ; o (string_of_bool u) ; 200 | o "] " 201 | 202 | and field (x, l) = o (soi x) ; o " = " ; idl l 203 | and action (x, e) = 204 | ty_id x ; o " -> " ; expr e ; nl() 205 | 206 | and maction (x, lbl) = 207 | value x ; o " -> jump " ; id lbl ; nl() 208 | 209 | and tid (_, x) = id x 210 | 211 | and value = function 212 | | Eunit -> o "unit" 213 | | Ebool b -> o (string_of_bool b) 214 | | Eint x -> o x 215 | | Efloat x -> o x 216 | | Echar x -> o x 217 | | Estring x -> o x 218 | | Eiint x -> o (soi x) 219 | 220 | and binop = function 221 | | Ast.Eeq -> o "eq" 222 | | Ast.Ediff -> o "diff" 223 | | Ast.Elt -> o "lt" 224 | | Ast.Elte -> o "lte" 225 | | Ast.Egt -> o "gt" 226 | | Ast.Egte -> o "gte" 227 | | Ast.Eplus -> o "plus" 228 | | Ast.Eminus -> o "minus" 229 | | Ast.Estar -> o "star" 230 | | Ast.Emod -> o "mod" 231 | | Ast.Ediv -> o "div" 232 | | Ast.Eor -> o "or" 233 | | Ast.Eand -> o "and" 234 | | Ast.Eband -> o "&" 235 | 236 | and unop = function 237 | | Ast.Euminus -> o "uminus" 238 | -------------------------------------------------------------------------------- /compiler/nast.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | 34 | type id = Pos.t * Ident.t 35 | type pstring = Pos.t * string 36 | 37 | type program = module_ list 38 | 39 | and module_ = { 40 | md_sig: bool ; 41 | md_id: id ; 42 | md_decls: decl list ; 43 | md_defs: def list ; 44 | } 45 | 46 | and decl = 47 | | Dtype of (id * type_expr) list 48 | | Dval of Ast.link * id * type_expr * Ast.extern_def 49 | 50 | and type_expr = Pos.t * type_expr_ 51 | and type_expr_ = 52 | | Tany 53 | | Tprim of type_prim 54 | | Tvar of id 55 | | Tid of id 56 | | Tapply of type_expr * type_expr list 57 | | Ttuple of type_expr list 58 | | Tpath of id * id 59 | | Tfun of Ast.fun_kind * type_expr * type_expr 60 | | Talgebric of (id * type_expr option) IMap.t 61 | | Trecord of (id * type_expr) IMap.t 62 | | Tabbrev of type_expr 63 | | Tabs of id list * type_expr 64 | | Tabstract 65 | 66 | and type_prim = 67 | | Tunit 68 | | Tbool 69 | | Tchar 70 | | Tint 71 | | Tfloat 72 | | Tstring 73 | 74 | and def = id * pat list * expr 75 | 76 | and tpat = pat * type_expr 77 | and pat = Pos.t * pat_ 78 | and pat_ = 79 | | Pany 80 | | Pid of id 81 | | Pvalue of value 82 | | Pcstr of id 83 | | Pvariant of id * pat 84 | | Pecstr of id * id 85 | | Pevariant of id * id * pat 86 | | Precord of pat_field list 87 | | Pbar of pat * pat 88 | | Ptuple of pat list 89 | | Pas of id * pat 90 | 91 | and pat_field = Pos.t * pat_field_ 92 | and pat_field_ = 93 | | PFany 94 | | PFid of id 95 | | PField of id * pat 96 | 97 | and expr = Pos.t * expr_ 98 | and expr_ = 99 | | Eid of id 100 | | Evalue of value 101 | | Ebinop of Ast.bop * expr * expr 102 | | Euop of Ast.uop * expr 103 | | Etuple of expr list 104 | | Ecstr of id 105 | | Erecord of (id * expr) list 106 | | Efield of expr * id 107 | | Ematch of expr * (pat * expr) list 108 | | Elet of pat * expr * expr 109 | | Eif of expr * expr * expr 110 | | Eapply of expr * expr list 111 | | Ewith of expr * (id * expr) list 112 | | Eseq of expr * expr 113 | | Eobs of id 114 | | Efree of id 115 | | Epartial of expr list 116 | | Efun of Ast.fun_kind * bool * tpat list * expr 117 | 118 | and value = 119 | | Eunit 120 | | Ebool of bool 121 | | Eint of pstring 122 | | Efloat of pstring 123 | | Echar of pstring 124 | | Estring of pstring 125 | 126 | -------------------------------------------------------------------------------- /compiler/neast.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | 34 | let fresh x = Ident.make (Ident.to_string x) 35 | 36 | type id = Nast.id 37 | type pstring = Nast.pstring 38 | 39 | type program = module_ list 40 | 41 | and module_ = { 42 | md_sig: bool ; 43 | md_id: id ; 44 | md_decls: decl list ; 45 | md_defs: def list ; 46 | } 47 | 48 | and decl = 49 | | Dalgebric of tdef 50 | | Drecord of tdef 51 | | Dabstract of id * id list 52 | | Dval of Ast.link * id * type_expr * Ast.extern_def 53 | 54 | and tdef = { 55 | td_id: id ; 56 | td_args: id list ; 57 | td_map: (id * type_expr_list) IMap.t 58 | } 59 | 60 | and type_expr = Pos.t * type_expr_ 61 | and type_expr_ = 62 | | Tany 63 | | Tprim of type_prim 64 | | Tvar of id 65 | | Tid of id 66 | | Tapply of id * type_expr_list 67 | | Tfun of Ast.fun_kind * type_expr_list * type_expr_list 68 | 69 | and type_expr_list = Pos.t * type_expr list 70 | 71 | and type_prim = Nast.type_prim = 72 | | Tunit 73 | | Tbool 74 | | Tchar 75 | | Tint 76 | | Tfloat 77 | | Tstring 78 | 79 | and def = id * pat * tuple 80 | 81 | and tpat = pat_el * type_expr 82 | 83 | and pat = Pos.t * pat_tuple list 84 | and pat_tuple = Pos.t * pat_el list 85 | and pat_el = Pos.t * pat_ 86 | and pat_ = 87 | | Pany 88 | | Pid of id 89 | | Pvalue of value 90 | | Pvariant of id * pat 91 | | Precord of pat_field list 92 | | Pas of id * pat 93 | 94 | and pat_field = Pos.t * pat_field_ 95 | and pat_field_ = 96 | | PFany 97 | | PFid of id 98 | | PField of id * pat 99 | 100 | and expr = Pos.t * expr_ 101 | and expr_ = 102 | | Eid of id 103 | | Evalue of value 104 | | Evariant of id * tuple 105 | | Ebinop of Ast.bop * expr * expr 106 | | Euop of Ast.uop * expr 107 | | Erecord of (id * tuple) list 108 | | Ewith of expr * (id * tuple) list 109 | | Efield of expr * id 110 | | Ematch of tuple * (pat * tuple) list 111 | | Elet of pat * tuple * tuple 112 | | Eif of expr * tuple * tuple 113 | | Eapply of id * tuple 114 | | Eseq of expr * tuple 115 | | Eobs of id 116 | | Efree of id 117 | | Epartial of expr * tuple 118 | | Ecall of expr * tuple 119 | | Efun of Ast.fun_kind * bool * tpat list * tuple 120 | 121 | and tuple = Pos.t * expr list 122 | 123 | and value = Nast.value 124 | 125 | module TVars = struct 126 | 127 | let rec type_expr env t (_, ty) = type_expr_ env t ty 128 | 129 | and type_expr_ env t = function 130 | | Tany 131 | | Tprim _ 132 | | Tid _ -> t 133 | | Tvar (_, x) -> 134 | (try type_expr env t (IMap.find x env) 135 | with Not_found -> ISet.add x t) 136 | | Tapply (_, tyl) -> 137 | type_expr_list env t tyl 138 | | Tfun (_, tyl1, tyl2) -> 139 | let t = type_expr_list env t tyl1 in 140 | let t = type_expr_list env t tyl2 in 141 | t 142 | 143 | and type_expr_list env t (_, tyl) = 144 | List.fold_left (type_expr env) t tyl 145 | 146 | end 147 | 148 | module Subst = struct 149 | 150 | let rec type_expr env t (p, ty) = 151 | p, type_expr_ env t ty 152 | 153 | and type_expr_ env t = function 154 | | Tany 155 | | Tprim _ 156 | | Tid _ as x -> x 157 | | Tvar (p, x) -> 158 | (try snd (type_expr env t (IMap.find x env)) 159 | with Not_found -> 160 | Tvar (p, IMap.find x t) 161 | ) 162 | | Tapply (x, tyl) -> Tapply (x, type_expr_list env t tyl) 163 | | Tfun (k, tyl1, tyl2) -> 164 | let tyl1 = type_expr_list env t tyl1 in 165 | let tyl2 = type_expr_list env t tyl2 in 166 | Tfun (k, tyl1, tyl2) 167 | 168 | and type_expr_list env t (p, tyl) = 169 | p, List.map (type_expr env t) tyl 170 | 171 | let make_name x acc = 172 | let name = fresh x in 173 | IMap.add x name acc 174 | 175 | end 176 | 177 | module Instantiate = struct 178 | 179 | let type_expr env ty = 180 | let tvars = TVars.type_expr env ISet.empty ty in 181 | let instv = ISet.fold Subst.make_name tvars IMap.empty in 182 | Subst.type_expr env instv ty 183 | 184 | let type_expr_list env tyl = 185 | let tvars = TVars.type_expr_list env ISet.empty tyl in 186 | let instv = ISet.fold Subst.make_name tvars IMap.empty in 187 | Subst.type_expr_list env instv tyl 188 | end 189 | 190 | module ExpandType = struct 191 | 192 | let rec id env ty x = 193 | try type_expr env (IMap.find x env) 194 | with Not_found -> ty 195 | 196 | and type_expr env ((p, ty_) as ty) = 197 | match ty_ with 198 | | Tvar (_, x) -> id env ty x 199 | | Tapply (x, tyl) -> 200 | p, Tapply (x, type_expr_list env tyl) 201 | | Tfun (fk, tyl1, tyl2) -> 202 | p, Tfun (fk, type_expr_list env tyl1, type_expr_list env tyl2) 203 | | _ -> ty 204 | 205 | and type_expr_list env (p, tyl) = 206 | p, List.map (type_expr env) tyl 207 | 208 | end 209 | 210 | 211 | module SubType = struct 212 | 213 | let rec type_expr (p1, ty1) (p2, ty2) = 214 | match ty1, ty2 with 215 | | Tvar _, Tany 216 | | Tany, Tvar _ -> () 217 | | Tvar _, Tvar _ -> () 218 | | Tvar _, _ -> Error.too_general p1 p2 219 | | Tapply (_, tyl1), Tapply (_, tyl2) -> 220 | type_expr_list tyl1 tyl2 221 | | Tfun (_, tyl1, tyl2), Tfun (_, tyl3, tyl4) -> 222 | type_expr_list tyl1 tyl3 ; 223 | type_expr_list tyl2 tyl4 224 | | _ -> () 225 | 226 | and type_expr_list (_, tyl1) (_, tyl2) = 227 | List.iter2 type_expr tyl1 tyl2 228 | 229 | end 230 | -------------------------------------------------------------------------------- /compiler/pos.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Lexing 33 | 34 | type t = { 35 | pos_file: string ; 36 | pos_start: Lexing.position ; 37 | pos_end: Lexing.position ; 38 | pos_history: t list ref ; 39 | } 40 | 41 | let file = ref "" 42 | 43 | let none = { 44 | pos_file = "" ; 45 | pos_start = dummy_pos ; 46 | pos_end = dummy_pos ; 47 | pos_history = ref [] ; 48 | } 49 | 50 | let make (lb:Lexing.lexbuf) = 51 | let pos_start = lexeme_start_p lb in 52 | let pos_end = lexeme_end_p lb in 53 | let pos_history = ref [] in 54 | { pos_file = !file; pos_start = pos_start ; 55 | pos_end = pos_end ; pos_history = pos_history } 56 | 57 | let btw x1 x2 = 58 | if x1.pos_file <> x2.pos_file 59 | then failwith "Position in separate files" ; 60 | if x1.pos_end > x2.pos_end 61 | then failwith "Invalid positions Pos.btw" ; 62 | { x1 with pos_end = x2.pos_end } 63 | 64 | let string t = 65 | let line = t.pos_start.pos_lnum in 66 | let start = t.pos_start.pos_cnum - t.pos_start.pos_bol in 67 | let end_ = start + t.pos_end.pos_cnum - t.pos_start.pos_cnum in 68 | Printf.sprintf "File \"%s\", line %d, characters %d-%d:" 69 | t.pos_file line start end_ 70 | 71 | let rec begin_end l = 72 | match l with 73 | | [] -> assert false 74 | | x :: _ -> fst x, end_ l 75 | 76 | and end_ x = 77 | match x with 78 | | [] -> assert false 79 | | [x] -> fst x 80 | | _ :: rl -> end_ rl 81 | 82 | let list l = 83 | let b, e = begin_end l in 84 | btw b e, l 85 | 86 | let push p h = 87 | p.pos_history := h :: !(p.pos_history) 88 | 89 | let history p = !(p.pos_history) 90 | 91 | let compare = Pervasives.compare 92 | -------------------------------------------------------------------------------- /compiler/stast.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | 34 | type id = Pos.t * Ident.t 35 | type pstring = Pos.t * string 36 | 37 | type program = module_ list 38 | 39 | and module_ = { 40 | md_sig: bool; 41 | md_id: id ; 42 | md_decls: decl list ; 43 | md_defs: def list ; 44 | } 45 | 46 | and decl = 47 | | Dalgebric of tdef 48 | | Drecord of tdef 49 | | Dval of Ast.link * id * type_expr * Ast.extern_def 50 | 51 | and tdef = { 52 | td_id: id ; 53 | td_args: id list ; 54 | td_map: (id * type_expr_list) IMap.t 55 | } 56 | 57 | and type_expr = Pos.t * type_expr_ 58 | and type_expr_ = 59 | | Tany 60 | | Tprim of type_prim 61 | | Tvar of id 62 | | Tid of id 63 | | Tapply of id * type_expr_list 64 | | Tfun of Ast.fun_kind * type_expr_list * type_expr_list 65 | 66 | and type_expr_list = Pos.t * type_expr list 67 | 68 | and type_prim = Nast.type_prim = 69 | | Tunit 70 | | Tbool 71 | | Tchar 72 | | Tint 73 | | Tfloat 74 | | Tstring 75 | 76 | and def = Ast.fun_kind * id * pat * tuple 77 | 78 | and pat = type_expr_list * pat_tuple list 79 | and pat_tuple = type_expr_list * pat_el list 80 | and pat_el = type_expr * pat_ 81 | and pat_ = 82 | | Pany 83 | | Pid of id 84 | | Pvalue of value 85 | | Pvariant of id * pat 86 | | Precord of pat_field list 87 | | Pas of id * pat 88 | 89 | and pat_field = Pos.t * pat_field_ 90 | and pat_field_ = 91 | | PFany 92 | | PFid of id 93 | | PField of id * pat 94 | 95 | and tuple = type_expr_list * tuple_pos list 96 | and tuple_pos = type_expr_list * expr_ 97 | and expr = type_expr * expr_ 98 | and expr_ = 99 | | Eid of id 100 | | Evalue of value 101 | | Evariant of id * tuple 102 | | Ebinop of Ast.bop * expr * expr 103 | | Euop of Ast.uop * expr 104 | | Erecord of (id * tuple) list 105 | | Ewith of expr * (id * tuple) list 106 | | Efield of expr * id 107 | | Ematch of tuple * (pat * tuple) list 108 | | Elet of pat * tuple * tuple 109 | | Eif of expr * tuple * tuple 110 | | Eapply of Ast.fun_kind * type_expr * id * tuple 111 | | Eseq of expr * tuple 112 | | Eobs of id 113 | | Efree of type_expr * id 114 | | Epartial of expr * tuple 115 | | Efun of Ast.fun_kind * bool * pat_el list * tuple 116 | 117 | and value = Nast.value = 118 | | Eunit 119 | | Ebool of bool 120 | | Eint of pstring 121 | | Efloat of pstring 122 | | Echar of pstring 123 | | Estring of pstring 124 | 125 | 126 | -------------------------------------------------------------------------------- /compiler/stastOfTast.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | open Tast 34 | 35 | 36 | module Env = struct 37 | 38 | type t = { 39 | types: type_expr IMap.t ; 40 | records: ISet.t ; 41 | } 42 | 43 | let rec program types mdl = 44 | let recs = ISet.empty in 45 | let recs = List.fold_left module_ recs mdl in 46 | { types = types ; records = recs } 47 | 48 | and module_ t md = 49 | List.fold_left decl t md.md_decls 50 | 51 | and decl t = function 52 | | Neast.Drecord td -> ISet.add (snd td.Neast.td_id) t 53 | | _ -> t 54 | end 55 | 56 | let check_binop op ((p, _) as ty) = 57 | let ty = 58 | match ty with 59 | | p, Stast.Tprim Stast.Tstring -> Error.no_string p 60 | | _, Stast.Tapply (x, (_, [_, Stast.Tprim ty])) when snd x = Naming.tobs -> ty 61 | | _, Stast.Tprim ty -> ty 62 | | p, _ -> Error.expected_primty p in 63 | match op, ty with 64 | | Ast.Eeq, _ 65 | | Ast.Ediff, _ 66 | | Ast.Elt, _ 67 | | Ast.Elte, _ 68 | | Ast.Egt, _ 69 | | Ast.Egte, _ -> () 70 | | Ast.Eplus, (Stast.Tint | Stast.Tfloat) -> () 71 | | Ast.Eminus, (Stast.Tint | Stast.Tfloat) -> () 72 | | Ast.Estar, (Stast.Tint | Stast.Tfloat) -> () 73 | | Ast.Ediv, (Stast.Tint | Stast.Tfloat) -> () 74 | | Ast.Emod, (Stast.Tint) -> () 75 | | Ast.Eor, (Stast.Tbool) -> () 76 | | Ast.Eand, (Stast.Tbool) -> () 77 | | _ -> Error.expected_numeric p 78 | 79 | let check_bool (ty, _) = 80 | match ty with 81 | | _, Neast.Tprim Neast.Tbool -> () 82 | | p, _ -> Error.expected_bool p 83 | 84 | let rec program types mdl = 85 | let t = Env.program types mdl in 86 | List.map (module_ t) mdl 87 | 88 | and module_ t md = { 89 | Stast.md_sig = md.md_sig ; 90 | Stast.md_id = md.md_id ; 91 | Stast.md_decls = List.fold_right (decl t) md.md_decls [] ; 92 | Stast.md_defs = List.map (def t) md.md_defs ; 93 | } 94 | 95 | and decl t d acc = 96 | match d with 97 | | Neast.Dabstract _ -> acc 98 | | Neast.Dalgebric td -> Stast.Dalgebric (tdef t td) :: acc 99 | | Neast.Drecord td -> Stast.Drecord (tdef t td) :: acc 100 | | Neast.Dval (ll, x, ty, v) -> Stast.Dval (ll, x, type_expr t ty, v) :: acc 101 | 102 | and tdef t td = { 103 | Stast.td_id = td.Neast.td_id ; 104 | Stast.td_args = td.Neast.td_args ; 105 | Stast.td_map = IMap.map (id_type t) td.Neast.td_map ; 106 | } 107 | 108 | and id_type t (x, tyl) = 109 | let tyl = type_expr_list t tyl in 110 | x, tyl 111 | 112 | and type_expr t (p, ty) = p, type_expr_ t ty 113 | and type_expr_ t = function 114 | | Neast.Tany -> Stast.Tany 115 | | Neast.Tprim ty -> Stast.Tprim ty 116 | | Neast.Tvar ((_, x) as v) -> 117 | (try snd (type_expr t (IMap.find x t.Env.types)) 118 | with Not_found -> Stast.Tvar v) 119 | | Neast.Tid x -> Stast.Tid x 120 | | Neast.Tapply (x, tyl) -> 121 | let tyl = type_expr_list t tyl in 122 | Stast.Tapply (x, tyl) 123 | | Neast.Tfun (k, tyl1, tyl2) -> 124 | Stast.Tfun (k, type_expr_list t tyl1, type_expr_list t tyl2) 125 | 126 | and type_expr_list t (p, tyl) = p, List.map (type_expr t) tyl 127 | 128 | and def t (k, x, p, e) = 129 | let e = tuple t e in 130 | k, x, pat t p, e 131 | 132 | and pat t (tyl, ptl) = type_expr_list t tyl, List.map (pat_tuple t) ptl 133 | and pat_tuple t (tyl, pel) = type_expr_list t tyl, List.map (pat_el t) pel 134 | and pat_el t (ty, p) = type_expr t ty, pat_ t p 135 | and pat_ t = function 136 | | Pany -> Stast.Pany 137 | | Pid x -> Stast.Pid x 138 | | Pvalue v -> Stast.Pvalue v 139 | | Pvariant (x, p) -> Stast.Pvariant (x, pat t p) 140 | | Precord pfl -> Stast.Precord (List.map (pat_field t) pfl) 141 | | Pas (x, p) -> Stast.Pas (x, pat t p) 142 | 143 | and pat_field t (p, pa) = p, pat_field_ t pa 144 | and pat_field_ t = function 145 | | PFany -> Stast.PFany 146 | | PFid x -> Stast.PFid x 147 | | PField (x, p) -> Stast.PField (x, pat t p) 148 | 149 | and tuple t (tyl, tpl) = type_expr_list t tyl, List.map (tuple_pos t) tpl 150 | and tuple_pos t (tyl, e) = 151 | let tyl = type_expr_list t tyl in 152 | tyl, expr_ t tyl e 153 | and expr t (ty, e) = 154 | let ty = type_expr t ty in 155 | ty, expr_ t (fst ty, [ty]) e 156 | 157 | and expr_ t ty = function 158 | | Eid x -> Stast.Eid x 159 | | Evalue v -> Stast.Evalue v 160 | | Evariant (id, e) -> 161 | let e = tuple t e in 162 | Stast.Evariant (id, e) 163 | | Ebinop (bop, e1, e2) -> 164 | let e1 = expr t e1 in 165 | let e2 = expr t e2 in 166 | check_binop bop (fst e1) ; 167 | Stast.Ebinop (bop, e1, e2) 168 | | Euop (uop, e) -> Stast.Euop (uop, expr t e) 169 | | Erecord (itl) -> Stast.Erecord (List.map (id_tuple t) itl) 170 | | Ewith (e, itl) -> 171 | let e = expr t e in 172 | Stast.Ewith (e, List.map (id_tuple t) itl) 173 | | Efield (e, x) -> Stast.Efield (expr t e, x) 174 | | Ematch (e, pal) -> Stast.Ematch (tuple t e, List.map (action t) pal) 175 | | Elet (p, e1, e2) -> 176 | let e1 = tuple t e1 in 177 | let e2 = tuple t e2 in 178 | Stast.Elet (pat t p, e1, e2) 179 | | Eif (e1, e2, e3) -> 180 | check_bool e1 ; 181 | let e2 = tuple t e2 in 182 | let e3 = tuple t e3 in 183 | Stast.Eif (expr t e1, e2, e3) 184 | | Eapply (fk, fty, x, e) -> 185 | let fty = type_expr t fty in 186 | let e = tuple t e in 187 | Stast.Eapply (fk, fty, x, e) 188 | | Eseq (e1, e2) -> 189 | let e2 = tuple t e2 in 190 | Stast.Eseq (expr t e1, e2) 191 | | Eobs x -> Stast.Eobs x 192 | | Efree (ty, x) -> 193 | let ty' = type_expr t ty in 194 | (match snd ty' with 195 | | Stast.Tapply ((_, x), _) 196 | | Stast.Tid (_, x) when ISet.mem x t.Env.records -> () 197 | | _ -> Error.cannot_free (fst ty) (Typing.Print.type_expr t.Env.types ty)) ; 198 | Stast.Efree (ty', x) 199 | | Epartial (f, e) -> 200 | let f = expr t f in 201 | let e = tuple t e in 202 | Stast.Epartial (f, e) 203 | | Efun (k, obs, idl, e) -> 204 | let idl = List.map (pat_el t) idl in 205 | let e = tuple t e in 206 | Stast.Efun (k, obs, idl, e) 207 | 208 | and id_tuple t (x, e) = 209 | let e = tuple t e in 210 | x, e 211 | 212 | and action t (p, a) = 213 | let e = tuple t a in 214 | pat t p, e 215 | -------------------------------------------------------------------------------- /compiler/tast.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | open Utils 33 | 34 | type id = Nast.id 35 | type pstring = Nast.pstring 36 | 37 | type program = module_ list 38 | 39 | and module_ = { 40 | md_sig: bool; 41 | md_id: id ; 42 | md_decls: Neast.decl list ; 43 | md_defs: def list ; 44 | } 45 | 46 | and type_expr = Neast.type_expr 47 | and type_expr_list = Neast.type_expr_list 48 | 49 | and def = Ast.fun_kind * id * pat * tuple 50 | 51 | and pat = type_expr_list * pat_tuple list 52 | and pat_tuple = type_expr_list * pat_el list 53 | and pat_el = type_expr * pat_ 54 | and pat_ = 55 | | Pany 56 | | Pid of id 57 | | Pvalue of value 58 | | Pvariant of id * pat 59 | | Precord of pat_field list 60 | | Pas of id * pat 61 | 62 | and pat_field = Pos.t * pat_field_ 63 | and pat_field_ = 64 | | PFany 65 | | PFid of id 66 | | PField of id * pat 67 | 68 | and tuple = type_expr_list * tuple_pos list 69 | and tuple_pos = type_expr_list * expr_ 70 | and expr = type_expr * expr_ 71 | and expr_ = 72 | | Eid of id 73 | | Evalue of value 74 | | Evariant of id * tuple 75 | | Ebinop of Ast.bop * expr * expr 76 | | Euop of Ast.uop * expr 77 | | Erecord of (id * tuple) list 78 | | Ewith of expr * (id * tuple) list 79 | | Efield of expr * id 80 | | Ematch of tuple * (pat * tuple) list 81 | | Elet of pat * tuple * tuple 82 | | Eif of expr * tuple * tuple 83 | | Eapply of Ast.fun_kind * type_expr * id * tuple 84 | | Epartial of expr * tuple 85 | | Eseq of expr * tuple 86 | | Eobs of id 87 | | Efree of type_expr * id 88 | | Efun of Ast.fun_kind * bool * pat_el list * tuple 89 | 90 | and value = Nast.value 91 | 92 | module FreeVars = struct 93 | 94 | let rec pat s (_, ptl) = List.fold_left pat_tuple s ptl 95 | and pat_tuple s (_, pl) = List.fold_left pat_el s pl 96 | and pat_el s (_, p) = pat_ s p 97 | and pat_ s = function 98 | | Pvalue _ 99 | | Pany -> s 100 | | Pid (_, x) -> ISet.add x s 101 | | Pvariant (_, p) -> pat s p 102 | | Precord pfl -> List.fold_left pat_field s pfl 103 | | Pas ((_, x), p) -> 104 | let s = ISet.add x s in 105 | pat s p 106 | 107 | and pat_field s (_, pf) = pat_field_ s pf 108 | and pat_field_ s = function 109 | | PFany -> s 110 | | PFid (_, x) -> ISet.add x s 111 | | PField (_, p) -> pat s p 112 | 113 | let pat p = pat ISet.empty p 114 | 115 | end 116 | 117 | -------------------------------------------------------------------------------- /compiler/utils.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | 33 | module Sid = struct type t = string let compare = String.compare end 34 | module SMap = Map.Make (Sid) 35 | module SSet = Set.Make (Sid) 36 | module IMap = Map.Make (Ident) 37 | module ISet = Set.Make (Ident) 38 | 39 | let o s = output_string stdout s ; flush stdout 40 | let on() = o "\n" 41 | 42 | let imap_of_list l = 43 | List.fold_left 44 | (fun acc (((_, x) as id), y) -> IMap.add x (id, y) acc) 45 | IMap.empty 46 | l 47 | 48 | let list_of_imap m = 49 | IMap.fold (fun _ y acc -> y :: acc) m [] 50 | 51 | let clist_of_imap m = 52 | IMap.fold (fun x y acc -> (x, y) :: acc) m [] 53 | 54 | let imfold f acc im = 55 | IMap.fold (fun x y acc -> f acc y) im acc 56 | 57 | let imiter f im = 58 | IMap.iter (fun _ x -> f x) im 59 | 60 | let imlfold f acc im = 61 | IMap.fold (fun x y (acc, im) -> 62 | let acc, y = f acc y in 63 | acc, IMap.add x y im) im (acc, IMap.empty) 64 | 65 | let imap2 f m1 m2 = 66 | IMap.fold (fun x t2 acc -> 67 | try let t1 = IMap.find x m1 in 68 | IMap.add x (f t1 t2) acc 69 | with Not_found -> acc) m2 m1 70 | 71 | let imap2 f m1 m2 = 72 | imap2 f (imap2 f m1 m2) m1 73 | 74 | let union m1 m2 = IMap.fold IMap.add m1 m2 75 | 76 | let iimap2 f m1 m2 = 77 | IMap.fold (fun x t2 acc -> 78 | try let t1 = IMap.find x m1 in 79 | IMap.add x (f x t1 t2) acc 80 | with Not_found -> acc) m2 m1 81 | 82 | let iimap2 f m1 m2 = 83 | iimap2 f (iimap2 f m1 m2) m1 84 | 85 | let lfold f acc l = 86 | let acc, l = List.fold_left (fun (acc,l) x -> 87 | let acc, x = f acc x in 88 | acc, x :: l) (acc, []) l in 89 | acc, List.rev l 90 | 91 | let lfold2 f acc l1 l2 = 92 | let acc, l = List.fold_left2 (fun (acc, l) x1 x2 -> 93 | let acc, x = f acc x1 x2 in 94 | acc, x :: l) (acc, []) l1 l2 in 95 | acc, List.rev l 96 | 97 | let ilfold2 f acc l1 l2 = 98 | let acc, _, l = List.fold_left2 (fun (acc, n, l) x1 x2 -> 99 | let acc, x = f n acc x1 x2 in 100 | acc, n+1, x :: l) (acc, 0, []) l1 l2 in 101 | acc, List.rev l 102 | 103 | let hdtl = function 104 | | x :: rl -> x, rl 105 | | _ -> assert false 106 | 107 | let rec uniq cmp = function 108 | | [] 109 | | [_] as l -> l 110 | | x :: y :: rl when cmp x y = 0 -> x :: uniq cmp rl 111 | | x :: rl -> x :: uniq cmp rl 112 | 113 | let uniq cmp l = uniq cmp (List.sort cmp l) 114 | 115 | let map_add t1 t2 = SMap.fold SMap.add t2 t1 116 | 117 | let option f = function None -> None | Some x -> Some (f x) 118 | let maybe f = function None -> () | Some x -> f x 119 | 120 | let fold_right f acc l = List.fold_right (fun x acc -> f acc x) l acc 121 | 122 | let rec print_list o f sep t = 123 | match t with 124 | | [] -> () 125 | | [x] -> f o x 126 | | x :: rl -> f o x ; o sep ; print_list o f sep rl 127 | 128 | let rec filter_opt l = 129 | match l with 130 | | [] -> [] 131 | | None :: rl -> filter_opt rl 132 | | Some x :: rl -> x :: filter_opt rl 133 | 134 | let opt f x = 135 | match x with 136 | | None -> None 137 | | Some x -> Some (f x) 138 | 139 | let opt2 f x y = 140 | match x, y with 141 | | None, None -> None 142 | | Some x, Some y -> Some (f x y) 143 | | _ -> raise (Invalid_argument "Utils.opt2") 144 | 145 | let soi = string_of_int 146 | 147 | let lone = function [x] -> x | _ -> raise Exit 148 | 149 | let rec cut l n = 150 | if n <= 0 151 | then l 152 | else 153 | match l with 154 | | [] -> [] 155 | | _ :: rl -> cut rl (n-1) 156 | 157 | let rec llast = function 158 | | [] -> assert false 159 | | [x] -> x 160 | | _ :: rl -> llast rl 161 | 162 | module L = struct 163 | 164 | let rec foldl f env acc l = 165 | match l with 166 | | [] -> acc 167 | | x :: rl -> 168 | let acc = f acc x in 169 | foldl f env acc rl 170 | 171 | let lfold f env acc l = 172 | let acc, l = List.fold_left (fun (acc,l) x -> 173 | let acc, x = f env acc x in 174 | acc, x :: l) (acc, []) l in 175 | acc, List.rev l 176 | 177 | end 178 | -------------------------------------------------------------------------------- /conf/size.c: -------------------------------------------------------------------------------- 1 | /* 2 | Program used to determin which kind of architecture we are dealing with 3 | */ 4 | 5 | #include 6 | 7 | int main(int argc, char** argv){ 8 | 9 | int isize = sizeof(long) ; 10 | int vsize = sizeof(void*) ; 11 | int fsize = sizeof(float) ; 12 | int dsize = sizeof(double) ; 13 | 14 | if(isize == 4){ 15 | if(vsize == 4 && fsize == 4){ 16 | printf("ARCH_32\n") ; return 0 ; 17 | } 18 | } 19 | 20 | if(isize == 8){ 21 | if(vsize == 8 && dsize == 8){ 22 | printf("ARCH_64\n"); return 0 ; 23 | } 24 | } 25 | 26 | printf("UNKOWN\n") ; 27 | return 0 ; 28 | } 29 | -------------------------------------------------------------------------------- /licence.txt: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (c) 2011, Julien Verlaguet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | 3. Neither the name of Julien Verlaguet nor the names of 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | *) 32 | -------------------------------------------------------------------------------- /stdlib/Makefile: -------------------------------------------------------------------------------- 1 | -include ../Makefile.config 2 | 3 | CC_OPT = -O3 4 | 5 | default: libliml.a 6 | 7 | .PHONY: libliml.a 8 | 9 | SOURCES =\ 10 | thread.c\ 11 | array.c\ 12 | print.c\ 13 | math.c\ 14 | string.c\ 15 | share.c\ 16 | debug.c 17 | 18 | LML_SOURCES =\ 19 | option.lml\ 20 | pervasives.lml\ 21 | array.lml \ 22 | print.lml \ 23 | string.lml \ 24 | math.lml \ 25 | thread.lml\ 26 | share.lml\ 27 | closure.lml\ 28 | list.lml 29 | 30 | OBJECTS = $(SOURCES:.c=.o) 31 | 32 | libliml.a: $(OBJECTS) $(LML_SOURCES) 33 | @rm -f libliml.a 34 | ../compiler/limlc -no-stdlib $(LML_SOURCES) -lib libliml.lmli 35 | $(AR) r libliml.a $(OBJECTS) 36 | 37 | ############################################################################## 38 | 39 | %.o : %.c 40 | $(CC) $(CC_OPT) $(CC_ARCH) -c $< 41 | 42 | 43 | ############################################################################### 44 | 45 | clean: 46 | rm -f *.o *~ libliml.a \#* 47 | 48 | -------------------------------------------------------------------------------- /stdlib/array.c: -------------------------------------------------------------------------------- 1 | #include"liml.h" 2 | 3 | lvalue liml_array_make(lvalue size__, lvalue call__, lvalue f){ 4 | lvalue size = (lvalue) size__ ; 5 | lvalue (*call)(lvalue, lvalue) = 6 | (lvalue (*)(lvalue, lvalue)) call__ ; 7 | lvalue i ; 8 | lvalue* t = malloc(sizeof(lvalue) * (size + 1)) ; 9 | *t = size ; 10 | t++ ; 11 | 12 | for(i = 0 ; i < size ; i++){ 13 | t[i] = call(f, i) ; 14 | } 15 | 16 | return (lvalue)t ; 17 | } 18 | 19 | lvalue liml_array_ifmake(lvalue size, lvalue n){ 20 | lvalue i ; 21 | lvalue* res = malloc(sizeof(lvalue) * (size + 1)) ; 22 | *res = size ; 23 | res++ ; 24 | for(i = 0 ; i < size ; i++){ 25 | res[i] = n ; 26 | } 27 | 28 | return (lvalue)res ; 29 | } 30 | 31 | lvalue liml_array_length(lvalue t__){ 32 | lvalue* t = (lvalue*) t__ ; 33 | return (lvalue)*(t-1) ; 34 | } 35 | 36 | lvalue liml_array_release(lvalue call__, lvalue f, lvalue t__){ 37 | lvalue* t = (lvalue*) t__ ; 38 | lvalue(*call)(lvalue, lvalue) = (lvalue(*)(lvalue,lvalue)) call__ ; 39 | lvalue i ; 40 | lvalue size = *(t-1) ; 41 | 42 | for(i = 0 ; i < size ; i++){ 43 | call(f, t[i]) ; 44 | } 45 | free(t-1) ; 46 | return 0; 47 | } 48 | 49 | lvalue liml_array_ifrelease(lvalue t__){ 50 | lvalue* t = (void*) t__; 51 | free(t-1) ; 52 | return 0; 53 | } 54 | -------------------------------------------------------------------------------- /stdlib/array.lml: -------------------------------------------------------------------------------- 1 | module Array = struct 2 | type 'a t 3 | 4 | val init_: int * ('a * int #-> 'b) * 'a #-> 'b t = "liml_array_make" 5 | val private fmake_: int * float #-> float t = "liml_array_ifmake" 6 | val private imake_: int * int #-> int t = "liml_array_ifmake" 7 | val set: 'a t * int * 'a -> 'a t = internal 8 | val get: 'a t obs * int -> 'a = internal 9 | val swap: 'a t * int * 'a -> 'a t * 'a = internal 10 | 11 | val private length_: 'a t obs #-> int = "liml_array_length" 12 | val private release_: ('a * 'b #-> unit) * 'a * 'b t #-> unit = "liml_array_release" 13 | val private irelease_: int t #-> unit = "liml_array_ifrelease" 14 | val private frelease_: float t #-> unit = "liml_array_ifrelease" 15 | 16 | val call_int: ('b -> 'a) * 'b #-> 'a 17 | let call_int f i = f i 18 | 19 | val call_unit: ('a -> unit) * 'a #-> unit 20 | let call_unit f i = f i 21 | 22 | val init: int * (int -> 'a) -> 'a t 23 | let init n f = init_ n call_int f 24 | 25 | val fmake: int * float -> float t 26 | let fmake size f = fmake_ size f 27 | 28 | val imake: int * int -> int t 29 | let imake size f = imake_ size f 30 | 31 | val length: 'a t obs -> int 32 | let length t = length_ t 33 | 34 | val release: ('a -> unit) * 'a t -> unit 35 | let release f t = 36 | release_ call_unit f t 37 | 38 | val irelease: int t -> unit 39 | let irelease t = irelease_ t 40 | 41 | val frelease: float t -> unit 42 | let frelease t = frelease_ t 43 | 44 | val debug: 'a obs #-> unit = "debug" 45 | end 46 | 47 | 48 | -------------------------------------------------------------------------------- /stdlib/box.lml: -------------------------------------------------------------------------------- 1 | 2 | module IntBox = struct 3 | 4 | type t = { value: int } 5 | 6 | val make: int -> t 7 | let make n = { value = n } 8 | 9 | val get: t obs -> int 10 | let get t = 11 | match t with 12 | | { _ ; value = n } -> n 13 | 14 | val unbox: t -> int 15 | let unbox x = 16 | let res = get !x in 17 | release x ; 18 | res 19 | 20 | val release: t -> unit 21 | let release t = free t 22 | 23 | val crelease: t #-> unit 24 | let crelease t = free t 25 | 26 | val add: t * t -> t 27 | let add x y = 28 | let n1 = get !x in 29 | let n2 = get !y in 30 | free x ; 31 | free y ; 32 | make (n1 + n2) 33 | end 34 | -------------------------------------------------------------------------------- /stdlib/closure.lml: -------------------------------------------------------------------------------- 1 | 2 | module Closure = struct 3 | 4 | type ('a, 'b) t = 5 | { env: _; 6 | f: _ * 'a -> _ * 'b ; 7 | g: _ -> unit; 8 | } 9 | 10 | val make: ('a * 'b -> 'a * 'c) * 'a * ('a -> unit) -> ('b, 'c) t 11 | let make f env g = { ~env; ~f; ~g } 12 | 13 | val call: ('a, 'b) t * 'a -> ('a, 'b) t * 'b 14 | let call f x = 15 | let { f; ~env } = f in 16 | let env, res = f.f env x in 17 | { f with ~env }, res 18 | 19 | val release: ('a, 'b) t -> unit 20 | let release t = 21 | let {t; ~env} = t in 22 | t.g env; 23 | free t 24 | 25 | end 26 | -------------------------------------------------------------------------------- /stdlib/debug.c: -------------------------------------------------------------------------------- 1 | #include "liml.h" 2 | #include 3 | 4 | lvalue debug(lvalue v){ 5 | printf("%p\n", (void*)v) ; 6 | return 0 ; 7 | } 8 | 9 | lvalue land(lvalue n1, lvalue n2){ 10 | return (n1 & n2) ; 11 | } 12 | 13 | lvalue lsl(lvalue n1, lvalue n2){ 14 | return (n1 << n2) ; 15 | } 16 | -------------------------------------------------------------------------------- /stdlib/farray.lml: -------------------------------------------------------------------------------- 1 | 2 | module UnsafeFloatArray = struct 3 | type t 4 | 5 | val make: int * float #-> t = "unsafe_farray_make" 6 | val release: t #-> unit = "unsafe_farray_release" 7 | val set: t * int * float -> t = asm "unsafe_farray_set" 8 | val get: t obs * int -> float = asm "unsafe_farray_get" 9 | 10 | end 11 | 12 | module FloatArray = struct 13 | 14 | type t = { 15 | size: int ; 16 | v: UnsafeFloatArray.t ; 17 | } 18 | 19 | val make: int * float -> t 20 | let make n d = 21 | { size = n ; 22 | v = UnsafeFloatArray.make n d } 23 | 24 | val set: t * int * float #-> t 25 | let set t x f = 26 | if x < 0 || x >= t.size 27 | then t 28 | else 29 | let { t ; ~v } = t in 30 | let v = UnsafeFloatArray.set v x f in 31 | { t with ~v } 32 | 33 | val get: t obs * int -> float 34 | let get t x = 35 | if x < 0 || x >= t.size 36 | then 0.0 37 | else UnsafeFloatArray.get t.v x 38 | 39 | val length: t obs -> int 40 | let length t = t.size 41 | 42 | val release: t -> unit 43 | let release t = 44 | let { t ; ~v } = t in 45 | UnsafeFloatArray.release v ; 46 | free t 47 | 48 | end 49 | -------------------------------------------------------------------------------- /stdlib/iarray.lml: -------------------------------------------------------------------------------- 1 | 2 | module UnsafeIntArray = struct 3 | type t 4 | 5 | val make: int * int #-> t = "unsafe_iarray_make" 6 | val release: t #-> unit = "unsafe_iarray_release" 7 | val set: t * int * int -> t = asm "unsafe_iarray_set" 8 | val get: t obs * int -> int = asm "unsafe_iarray_get" 9 | val copy: t obs * t * int #-> t = "unsafe_iarray_copy" 10 | 11 | end 12 | 13 | module IntArray = struct 14 | 15 | type t = { 16 | size: int ; 17 | v: UnsafeIntArray.t ; 18 | } 19 | 20 | val make: int * int -> t 21 | let make n d = 22 | { size = n ; 23 | v = UnsafeIntArray.make n d } 24 | 25 | val set: t * int * int #-> t 26 | let set t x f = 27 | if x < 0 || x >= t.size 28 | then t 29 | else 30 | let { t ; ~v } = t in 31 | let v = UnsafeIntArray.set v x f in 32 | { t with ~v } 33 | 34 | val get: t obs * int -> int 35 | let get t x = 36 | if x < 0 || x >= t.size 37 | then 0 38 | else UnsafeIntArray.get t.v x 39 | 40 | val length: t obs -> int 41 | let length t = t.size 42 | 43 | val release: t -> unit 44 | let release t = 45 | let { t ; ~v } = t in 46 | UnsafeIntArray.release v ; 47 | free t 48 | 49 | end 50 | -------------------------------------------------------------------------------- /stdlib/liml.h: -------------------------------------------------------------------------------- 1 | #include "./config.h" 2 | 3 | #include 4 | 5 | #ifdef ARCH_32 6 | 7 | typedef lint lvalue ; 8 | #define lfloat float; 9 | 10 | #define V2F(x) (*((float*)&(x))) 11 | #define F2V(x) ((lvalue)(*((int*)&(x)))) 12 | 13 | #endif 14 | 15 | #ifdef ARCH_64 16 | 17 | typedef long lvalue ; 18 | #define lint long 19 | #define lfloat double 20 | 21 | #define V2F(x) (*((double*)&(x))) 22 | #define F2V(x) (*((long*)&(x))) 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /stdlib/list.lml: -------------------------------------------------------------------------------- 1 | module List = struct 2 | 3 | type 'a t = 4 | | Empty 5 | | Cons of 'a * 'a t 6 | 7 | val rev_append: 'a t * 'a t -> 'a t 8 | let rev_append acc l = 9 | match l with 10 | | [] -> acc 11 | | x :: rl -> rev_append (x :: acc) rl 12 | 13 | val rev: 'a t -> 'a t 14 | let rev l = rev_append [] l 15 | 16 | val append: 'b t * 'b t -> 'b t 17 | let append l1 l2 = 18 | match l1 with 19 | | [] -> l2 20 | | x :: rl -> x :: append rl l2 21 | 22 | val flatten: 'a t t -> 'a t 23 | let flatten l = 24 | match l with 25 | | [] -> [] 26 | | x :: rl -> append x (flatten rl) 27 | 28 | val map: ('a -> 'b) obs * 'a t -> 'b t 29 | let map f l = 30 | match l with 31 | | [] -> [] 32 | | x :: rl -> f x :: map f rl 33 | 34 | val map_acc: ('a * 'b -> 'a * 'c) obs * 'a * 'b t -> 'a * 'c t 35 | let map_acc f acc l = 36 | match l with 37 | | [] -> acc, [] 38 | | x :: rl -> 39 | let acc, x = f acc x in 40 | let acc, rl = map_acc f acc rl in 41 | acc, x :: rl 42 | 43 | val fold_left: ('a * 'b -> 'a) obs * 'a * 'b t -> 'a 44 | let fold_left f acc l = 45 | match l with 46 | | [] -> acc 47 | | x :: rl -> 48 | let acc = f acc x in 49 | fold_left f acc rl 50 | 51 | val fold_right: ('a * 'b -> 'b) obs * 'a t * 'b -> 'b 52 | let fold_right f l acc = 53 | match l with 54 | | [] -> acc 55 | | x :: rl -> fold_right f rl (f x acc) 56 | 57 | val release: ('a -> unit) * 'a t -> unit 58 | let release f l = 59 | match l with 60 | | [] -> () 61 | | x :: rl -> f x ; release f rl 62 | end 63 | 64 | -------------------------------------------------------------------------------- /stdlib/math.c: -------------------------------------------------------------------------------- 1 | #include"liml.h" 2 | #include 3 | 4 | lvalue liml_sqrt(lvalue arg){ 5 | lfloat res = sqrt(V2F(arg)) ; 6 | return F2V(res) ; 7 | } 8 | 9 | lvalue liml_sin(lvalue arg){ 10 | lfloat res = sin(V2F(arg)) ; 11 | return F2V(res) ; 12 | 13 | } 14 | 15 | lvalue liml_float_of_int(lvalue arg){ 16 | lfloat x = (lfloat)arg; 17 | return F2V(x) ; 18 | } 19 | -------------------------------------------------------------------------------- /stdlib/math.lml: -------------------------------------------------------------------------------- 1 | 2 | module Math = struct 3 | val sqrt: float #-> float = "liml_sqrt" 4 | val sin: float #-> float = "liml_sin" 5 | val float_of_int: int #-> float = "liml_float_of_int" 6 | end 7 | -------------------------------------------------------------------------------- /stdlib/option.lml: -------------------------------------------------------------------------------- 1 | module Option = struct 2 | 3 | type 'a t = 4 | | None 5 | | Some of 'a 6 | end 7 | -------------------------------------------------------------------------------- /stdlib/pervasives.lml: -------------------------------------------------------------------------------- 1 | 2 | module Pervasives = struct 3 | 4 | val c_abs: int #-> int = "abs" 5 | 6 | val abs: int -> int 7 | let abs x = c_abs x 8 | end 9 | -------------------------------------------------------------------------------- /stdlib/print.c: -------------------------------------------------------------------------------- 1 | #include"liml.h" 2 | #include 3 | 4 | lvalue print_int(lvalue n__){ 5 | int n = (int) n__ ; 6 | printf("%d", n) ; 7 | return 0 ; 8 | } 9 | 10 | lvalue print_newline(){ 11 | printf("\n") ; 12 | return 0 ; 13 | } 14 | 15 | lvalue print_float(lvalue x__){ 16 | float x = V2F(x__) ; 17 | printf("%f", x) ; 18 | return 0 ; 19 | } 20 | 21 | lvalue print_string(lvalue x__){ 22 | char *x = (char*) x__ ; 23 | printf("%s", x) ; 24 | return 0 ; 25 | } 26 | 27 | lvalue print_char(lvalue x){ 28 | printf("%c", (char)x) ; 29 | return 0; 30 | } 31 | -------------------------------------------------------------------------------- /stdlib/print.lml: -------------------------------------------------------------------------------- 1 | 2 | module Print = struct 3 | 4 | val c_char: char #-> unit = "print_char" 5 | val c_int: int #-> unit = "print_int" 6 | val c_newline: unit #-> unit = "print_newline" 7 | val c_float: float #-> unit = "print_float" 8 | val c_string: string #-> unit = "print_string" 9 | val c_rstring: String.t obs #-> unit = "print_string" 10 | 11 | val char: char -> unit 12 | let char c = c_char c 13 | 14 | val int: int -> unit 15 | let int x = c_int x 16 | 17 | val newline: unit -> unit 18 | let newline () = c_newline() 19 | 20 | val float: float -> unit 21 | let float x = c_float x 22 | 23 | val string: string -> unit 24 | let string x = c_string x 25 | 26 | val rstring: String.t obs -> unit 27 | let rstring x = c_rstring x 28 | 29 | end 30 | -------------------------------------------------------------------------------- /stdlib/share.c: -------------------------------------------------------------------------------- 1 | #include "liml.h" 2 | 3 | #include 4 | 5 | typedef struct{ 6 | lvalue counter ; 7 | void* value ; 8 | } share_t ; 9 | 10 | share_t* share_make(void* value){ 11 | share_t *res = malloc(sizeof(share_t)) ; 12 | res->counter = 1 ; 13 | res->value = value ; 14 | return res ; 15 | } 16 | 17 | share_t* share_clone(share_t* x){ 18 | __sync_fetch_and_add(&x->counter, 1) ; 19 | return x ; 20 | } 21 | 22 | void** share_release(share_t* x){ 23 | __sync_fetch_and_sub(&x->counter, 1) ; 24 | if (x->counter == 1){ 25 | void** res = malloc(sizeof(lvalue)); 26 | *res = x->value ; 27 | return res ; 28 | } 29 | return NULL ; 30 | } 31 | 32 | void* share_visit(share_t* x){ 33 | return x->value ; 34 | } 35 | -------------------------------------------------------------------------------- /stdlib/share.lml: -------------------------------------------------------------------------------- 1 | 2 | module Share = struct 3 | 4 | type 'a t 5 | 6 | val c_make: 'a #-> 'a t = "share_make" 7 | val c_clone: 'a t obs #-> 'a t = "share_clone" 8 | val c_release: 'a t #-> 'a Option.t = "share_release" 9 | val visit: 'a t obs #-> 'a obs = "share_visit" 10 | 11 | val make: 'a -> 'a t 12 | let make x = c_make x 13 | 14 | val clone: 'a t obs -> 'a t 15 | let clone x = c_clone x 16 | 17 | val release: 'a t -> 'a Option.t 18 | let release x = c_release x 19 | 20 | end 21 | -------------------------------------------------------------------------------- /stdlib/string.c: -------------------------------------------------------------------------------- 1 | #include "liml.h" 2 | #include 3 | 4 | lvalue string_make(lvalue v_){ 5 | char* v = (char*)v_ ; 6 | char* s ; 7 | lvalue* ptr; 8 | lvalue size = strlen(v) ; 9 | 10 | s = malloc(size + sizeof(lvalue) + 1) ; 11 | ptr = (lvalue*)s ; 12 | *ptr = size ; 13 | s = (char*) (ptr+1) ; 14 | strcpy(s, v) ; 15 | return (lvalue)s ; 16 | } 17 | 18 | lvalue string_release(lvalue s){ 19 | lvalue* ptr = (lvalue*) s ; 20 | free(ptr-1) ; 21 | return 0 ; 22 | } 23 | 24 | lvalue string_length(lvalue s){ 25 | lvalue* ptr = (lvalue*) s ; 26 | return (*(ptr-1)) ; 27 | } 28 | 29 | lvalue string_concat(lvalue s1, lvalue s2){ 30 | lvalue size1 = string_length(s1) ; 31 | lvalue size2 = string_length(s2) ; 32 | lvalue size = size1 + size2 ; 33 | lvalue* ptr ; 34 | 35 | char* res = malloc (size + 1 + sizeof(lvalue)) ; 36 | *((lvalue*)res) = size ; 37 | res = res + sizeof(lvalue) ; 38 | strcpy(res, (char*)s1) ; 39 | strcpy(res+size1, (char*)s2) ; 40 | 41 | return (lvalue) res ; 42 | } 43 | 44 | -------------------------------------------------------------------------------- /stdlib/string.lml: -------------------------------------------------------------------------------- 1 | 2 | module String = struct 3 | 4 | type t 5 | 6 | val private c_make: string #-> t = "string_make" 7 | val private c_length: t obs #-> int = "string_length" 8 | val private c_release: t #-> unit = "string_release" 9 | val private c_append: t obs * t obs #-> t = "string_concat" 10 | val private c_compare: t obs * t obs #-> int = "strcmp" 11 | 12 | val make: string -> t 13 | let make s = c_make s 14 | 15 | val length: t obs -> int 16 | let length s = c_length !s 17 | 18 | val release: t -> unit 19 | let release s = c_release s 20 | 21 | val append_obs: t obs * t obs -> t 22 | let append_obs s1 s2 = 23 | let res = c_append !s1 !s2 in 24 | res 25 | 26 | val append: t * t -> t 27 | let append s1 s2 = 28 | let res = c_append !s1 !s2 in 29 | release s1 ; 30 | release s2 ; 31 | res 32 | 33 | val compare: t obs * t obs -> int 34 | let compare s1 s2 = c_compare s1 s2 35 | 36 | end 37 | -------------------------------------------------------------------------------- /stdlib/thread.c: -------------------------------------------------------------------------------- 1 | #include "liml.h" 2 | #include 3 | #include 4 | 5 | typedef struct{ 6 | void* v ; 7 | pthread_mutex_t m ; 8 | pthread_cond_t c ; 9 | } future ; 10 | 11 | typedef struct{ 12 | void* (*f)(void*) ; 13 | void* args ; 14 | future* res ; 15 | } cont ; 16 | 17 | void* call(void* k_arg){ 18 | cont* k = (cont*)k_arg ; 19 | future* res = k->res ; 20 | void* (*f)(void*) = k->f ; 21 | void* args = k-> args ; 22 | free(k) ; 23 | pthread_mutex_lock(&(res->m)) ; 24 | res->v = f(args) ; 25 | pthread_cond_signal(&(res->c)) ; 26 | pthread_mutex_unlock(&(res->m)) ; 27 | } 28 | 29 | future* future_make(void* (*f)(void*), void* args){ 30 | pthread_t thread ; 31 | cont* k = malloc (sizeof(cont)); 32 | future* res = malloc(sizeof(future)) ; 33 | 34 | k->f = f ; 35 | k->args = args ; 36 | k->res = res ; 37 | res->v = NULL ; 38 | pthread_mutex_init(&(res->m), NULL) ; 39 | pthread_cond_init(&(res->c), NULL) ; 40 | pthread_create(&thread, NULL, call, k); 41 | 42 | return res ; 43 | } 44 | 45 | void* future_wait(future* t){ 46 | void* res ; 47 | pthread_mutex_lock(&(t->m)) ; 48 | while(t->v == NULL){ 49 | pthread_cond_wait(&(t->c), &(t->m)) ; 50 | } 51 | res = t->v ; 52 | pthread_mutex_unlock(&(t->m)) ; 53 | free(t) ; 54 | return res ; 55 | } 56 | 57 | lvalue future_ready(future* t){ 58 | return (t->v == NULL) ; 59 | } 60 | 61 | void* future_make_value(void* v){ 62 | future* res ; 63 | res = malloc(sizeof(future)) ; 64 | res->v = v ; 65 | pthread_mutex_init(&(res->m), NULL) ; 66 | pthread_cond_init(&(res->c), NULL) ; 67 | 68 | return res ; 69 | } 70 | -------------------------------------------------------------------------------- /stdlib/thread.lml: -------------------------------------------------------------------------------- 1 | 2 | module Future = struct 3 | 4 | type 'a t 5 | 6 | val c_make: ('a #-> 'b) * 'a #-> 'b t = "future_make" 7 | val c_wait: 'a t #-> 'a = "future_wait" 8 | val c_ready: 'a t obs #-> int = "future_ready" 9 | 10 | val make: ('a #-> 'b) * 'a -> 'b t 11 | let make f x = c_make f x 12 | 13 | val make_value: 'a #-> 'a t = "future_make_value" 14 | 15 | val wait: 'a t -> 'a 16 | let wait x = c_wait x 17 | 18 | val ready: 'a t obs -> bool 19 | let ready x = c_ready x = 0 20 | end 21 | -------------------------------------------------------------------------------- /test/array_test.lml: -------------------------------------------------------------------------------- 1 | 2 | module TestArray = struct 3 | 4 | module IB = IntBox 5 | 6 | type ibox = IB.t 7 | 8 | val free_ibox: ibox #-> unit 9 | let free_ibox x = free x 10 | 11 | val free_opt: ibox option -> unit 12 | let free_opt x = 13 | match x with 14 | | None -> () 15 | | Some v -> IB.release v 16 | 17 | val init: int * ibox Array.t -> ibox Array.t 18 | let init n t = 19 | if n < 0 20 | then t 21 | else 22 | let t, v = Array.swap t n (Some (IB.make n)) in 23 | free_opt v ; 24 | init (n-1) t 25 | 26 | val sum: int * int * ibox Array.t -> int 27 | let sum acc n t = 28 | if n < 0 29 | then (Array.release t free_ibox; acc) 30 | else 31 | let t, v = Array.swap t n None in 32 | match v with 33 | | None -> sum acc (n-1) t 34 | | Some ib -> 35 | let v = IB.get (obs ib) in 36 | IB.release ib ; 37 | sum (acc+v) (n-1) t 38 | 39 | val add_opt: IB.t * IB.t option #-> IB.t 40 | let add_opt x y = 41 | match y with 42 | | None -> x 43 | | Some y -> IB.add x y 44 | 45 | val test_fold: unit #-> unit 46 | let test_fold() = 47 | let size = 10000000 in 48 | let t = Array.make size in 49 | t := init (size - 1) t ; 50 | let total = Array.fold_left add_opt (IB.make 0) t in 51 | Print.int (IB.get (obs total)) ; 52 | Print.newline() ; 53 | IB.release total 54 | 55 | end 56 | -------------------------------------------------------------------------------- /test/llvm_bugs/bug_call_sin.as: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'T' 2 | 3 | define void @main() { 4 | __tmp: 5 | %0 = call float @T_id(float 1.000000e+00) 6 | call void @print_float(float %0) 7 | ret void 8 | } 9 | 10 | define float @T_id(float) { 11 | __tmp: 12 | %1 = call float @sin(float %0) 13 | call void @print_float(float %1) 14 | ret float %1 15 | } 16 | 17 | declare float @sin(float) 18 | 19 | declare void @print_float(float) 20 | -------------------------------------------------------------------------------- /test/llvm_bugs/bug_call_sin.lml: -------------------------------------------------------------------------------- 1 | module T = struct 2 | 3 | val sin: float #-> float = "sin" 4 | val print: float #-> unit = "print_float" 5 | 6 | val id: float #-> float 7 | let id x = 8 | let res = sin x in 9 | print res ; 10 | res 11 | 12 | val main: unit #-> unit 13 | let main () = 14 | let f = 1.0 in 15 | print (id f) 16 | 17 | end 18 | -------------------------------------------------------------------------------- /test/llvm_bugs/bug_tail_call_opt.lml: -------------------------------------------------------------------------------- 1 | 2 | module Fankuch = struct 3 | 4 | 5 | val do_iter: int * int * int * int -> int * int * int * int 6 | let do_iter m n num perm = 7 | if n = 1 then begin 8 | m, n, num, perm 9 | end else 10 | do_iter_loop m n num perm 11 | 12 | val do_iter_loop: int * int * int * int -> int * int * int * int 13 | let do_iter_loop m n num perm = 14 | m, n, num, perm 15 | 16 | val main: unit #-> unit 17 | let main () = 18 | let m, n, num, perm = do_iter 0 0 0 0 in 19 | Print.int n ; 20 | Print.newline() ; 21 | Print.newline() 22 | 23 | 24 | end 25 | -------------------------------------------------------------------------------- /test/llvm_bugs/bug_trampoline.as: -------------------------------------------------------------------------------- 1 | ; Bugs when interpreted with lli -O0 2 | 3 | ; ModuleID = 'T' 4 | 5 | %0 = type { i32 } 6 | 7 | define fastcc i32 @T_add(i32, i32) { 8 | __tmp48: 9 | %__tmp45 = add i32 %0, %1 10 | ret i32 %__tmp45 11 | } 12 | 13 | define i32 @f(i8* nest, i32) { 14 | ; %3 = getelementptr inbounds %0* %0, i32 0, i32 0 15 | ; %4 = load i32* %3 16 | ; %5 = call fastcc i32 @T_add(i32 %4, i32 %1) 17 | ret i32 0 ; %5 18 | } 19 | 20 | 21 | define void @main() { 22 | __tmp44: 23 | %0 = alloca %0 24 | %1 = getelementptr inbounds %0* %0, i32 0, i32 0 25 | store i32 1, i32* %1 26 | %2 = alloca [10 x i8], align 4 27 | %3 = getelementptr [10 x i8]* %2, i32 0, i32 0 28 | %4 = bitcast i32* %1 to i8* 29 | %5 = call i8* @llvm.init.trampoline(i8* %3, i8* bitcast (i32 (i8* nest, i32)* @f to i8*), i8* %4) 30 | %6 = bitcast i8* %5 to i32 (i32)* 31 | %7 = call i32 %6(i32 1) 32 | ret void 33 | } 34 | 35 | declare i8* @llvm.init.trampoline(i8*, i8*, i8*) nounwind 36 | 37 | -------------------------------------------------------------------------------- /test/my_main.c: -------------------------------------------------------------------------------- 1 | 2 | 3 | int main(){ 4 | TestArray_test_fold() ; 5 | return 0 ; 6 | } 7 | -------------------------------------------------------------------------------- /test/parsort.lml: -------------------------------------------------------------------------------- 1 | 2 | module TestParsort = struct 3 | 4 | type t = 5 | | Empty 6 | | Cons of int * t 7 | 8 | val length: t obs * int -> int 9 | let length t acc = 10 | match t with 11 | | Empty -> acc 12 | | Cons n t -> length t (acc+1) 13 | 14 | val copy: t obs -> t 15 | let copy t = 16 | match t with 17 | | Empty -> Empty 18 | | Cons n t -> Cons n (copy t) 19 | 20 | val ff: t -> unit 21 | let ff t = 22 | match t with 23 | | Empty -> () 24 | | Cons _ t -> ff t 25 | 26 | val to_array: int Array.t * t * int -> int Array.t 27 | let to_array t l i = 28 | match l with 29 | | Empty -> t 30 | | Cons n l -> t.(i) <- n ; to_array t l (i+1) 31 | 32 | val from_array: int Array.t obs * t * int -> t 33 | let from_array t acc i = 34 | if i < 0 then acc 35 | else from_array t (Cons t.(i) acc) (i-1) 36 | 37 | val rev_append: t * t -> t 38 | let rev_append l1 l2 = 39 | match l1 with 40 | | Empty -> l2 41 | | Cons x rl -> rev_append rl (Cons x l2) 42 | 43 | val merge: t * t * t -> t 44 | let merge acc l1 l2 = 45 | match l1, l2 with 46 | | Empty, l -> rev_append l acc 47 | | l, Empty -> rev_append l acc 48 | (* Arghh the as pattern is buggy in linear check ... *) 49 | (* 50 | | (Cons x1 rl1 as l1), (Cons x2 rl2 as l2) -> 51 | if x1 > x2 52 | then merge (Cons x1 acc) rl1 l2 53 | else merge (Cons x2 acc) l1 rl2 54 | *) 55 | | Cons x1 rl1, Cons x2 rl2 -> 56 | if x1 > x2 57 | then merge (Cons x1 acc) rl1 (Cons x2 rl2) 58 | else merge (Cons x2 acc) (Cons x1 rl1) rl2 59 | 60 | val split: int * t * t * t -> int * t * t 61 | let split n l1 l2 l = 62 | match l with 63 | | Empty -> n, l1, l2 64 | | Cons x Empty -> n, l1, l2 65 | | Cons x (Cons y rl) -> split (n+1) (Cons x l1) (Cons y l2) rl 66 | 67 | val c_sort: t #-> t 68 | let c_sort l = 69 | let res = msort l in 70 | res 71 | 72 | val msort: t -> t 73 | let msort l = 74 | match l with 75 | | Empty -> Empty 76 | | Cons _ Empty as l -> l 77 | | Cons x rl as l -> 78 | let length1, l1, l2 = split 0 Empty Empty l in 79 | merge Empty (msort l1) (msort l2) 80 | 81 | val sort: t -> t 82 | let sort l = 83 | let length1, l1, l2 = split 0 Empty Empty l in 84 | if false 85 | then 86 | let l1 = Future.make c_sort l1 in 87 | let l2 = msort l2 in 88 | merge Empty (Future.wait l1) l2 89 | else merge Empty (msort l1) (msort l2) 90 | 91 | val make: t * int -> t 92 | let make acc n = 93 | if n = 0 94 | then acc 95 | else make (Cons n acc) (n-1) 96 | 97 | val sum: int * t -> int 98 | let sum acc l = 99 | match l with 100 | | Empty -> acc 101 | | Cons n rl -> sum (n + acc) rl 102 | 103 | val loop: int * int -> int 104 | let loop n acc = 105 | if n <= 0 106 | then acc 107 | else loop (n-1) (acc + sum 0 (sort (make Empty 100000))) 108 | 109 | val main: unit -> unit 110 | let main _ = 111 | Print.int (loop 1 0) 112 | 113 | end 114 | -------------------------------------------------------------------------------- /test/regression/unit.lml: -------------------------------------------------------------------------------- 1 | (* 2 | Test contributed by: Magnus Jonsson 3 | issue 5 in github 4 | *) 5 | 6 | module Main = struct 7 | val main: unit -> unit 8 | let main() = 9 | let d = () 10 | in (!fun () -> d) () 11 | end 12 | -------------------------------------------------------------------------------- /test/regression/unit2.lml: -------------------------------------------------------------------------------- 1 | module Main = struct 2 | 3 | val pp: unit -> unit 4 | let pp() = 5 | Print.string "OK\n" 6 | 7 | val main: unit -> unit 8 | let main() = 9 | let d = () 10 | in (!fun () -> pp d) () 11 | end 12 | -------------------------------------------------------------------------------- /test/shootout/Makefile: -------------------------------------------------------------------------------- 1 | 2 | LIMLC = ../../compiler/limlc 3 | 4 | 5 | default: fankuch.run bintree.run spectral.run 6 | 7 | %.run: %.lml 8 | $(LIMLC) $< -root Main -o $@ 9 | 10 | clean: 11 | rm -f ./bintree.run ./spectral.run ./fankuch.run 12 | rm -f *.o *.s *.bc *~ test/*.o test/*.s 13 | 14 | -------------------------------------------------------------------------------- /test/shootout/README: -------------------------------------------------------------------------------- 1 | This directory contains the micro benchmarks of the now famous "debian shootout" 2 | -------------------------------------------------------------------------------- /test/shootout/bintree.lml: -------------------------------------------------------------------------------- 1 | 2 | module Main = struct 3 | 4 | val lsl: int * int -> int 5 | let lsl x y = 6 | if y <= 0 then x else 2*lsl x (y-1) 7 | 8 | type tree = Empty | Node of tree * int * tree 9 | 10 | val private make: int * int -> tree 11 | let make i d = 12 | if d = 0 then Node(Empty, i, Empty) 13 | else 14 | let i2 = 2 * i in 15 | let d = d - 1 in 16 | Node(make (i2 - 1) d, i, make i2 d) 17 | 18 | val private check: tree -> int 19 | let check t = 20 | match t with 21 | | Empty -> 0 22 | | Node(l, i, r) -> i + check l - check r 23 | 24 | type loop2_params = { 25 | pd: int ; 26 | pi: int ; 27 | piend: int ; 28 | pc: int ; 29 | } 30 | 31 | val private loop2_start: loop2_params #-> int 32 | let loop2_start params = 33 | let { params ; pd = d ; pi = i ; piend = iend ; pc = c } = params in 34 | free params ; 35 | loop2 d i iend c 36 | 37 | val private loop2: int * int * int * int -> int 38 | let loop2 d i iend c = 39 | if i > iend 40 | then c 41 | else begin 42 | let c = c + check(make i d) + check(make (0-i) d) in 43 | loop2 d (i+1) iend c 44 | end 45 | 46 | type loop1_result = { 47 | d: int ; 48 | niter: int ; 49 | c: int ; 50 | } 51 | 52 | val private loop1: int * int * int * int * int * int * loop1_result List.t 53 | -> loop1_result List.t 54 | let loop1 min_depth max_depth d threads i iend acc = 55 | if i > iend 56 | then acc 57 | else begin 58 | let dv = d + (i * 2) in 59 | let niter = lsl 1 (max_depth - dv + min_depth) in 60 | let loop2_params = { pd = d ; pi = 1 ; piend = niter ; pc = 0 } in 61 | let c = loop2_start loop2_params in 62 | let result = { d = dv ; ~niter ; ~c } in 63 | let acc = List.Cons result acc in 64 | loop1 min_depth max_depth d threads (i+1) iend acc 65 | end 66 | 67 | val private loop_depths: int * int * int -> loop1_result List.t 68 | let loop_depths min_depth max_depth d = 69 | let last = ((max_depth - d) / 2 + 1) - 1 in 70 | let threads = 2 in 71 | loop1 min_depth max_depth d threads 0 last List.Empty 72 | 73 | val debug: 'a obs #-> unit = "liml_debug" 74 | 75 | val private print_results: loop1_result List.t -> unit 76 | let print_results l = 77 | match l with 78 | | List.Empty -> () 79 | | List.Cons res rl -> 80 | let { res ; ~d ; ~niter ; ~c } = res in 81 | Print.int (2 * niter) ; 82 | Print.string "\t trees of depth " ; 83 | Print.int d ; 84 | Print.string "\t check: " ; 85 | Print.int c ; 86 | Print.newline() ; 87 | free res ; 88 | print_results rl 89 | 90 | val main: unit -> unit 91 | let main() = 92 | let min_depth = 4 in 93 | let max_depth = 20 in 94 | let stretch_depth = max_depth + 1 in 95 | let c = check (make 0 stretch_depth) in 96 | Print.string "stretch tree of depth " ; 97 | Print.int stretch_depth ; 98 | Print.string "\t check: " ; 99 | Print.int c ; 100 | Print.newline() ; 101 | let long_lived_tree = make 0 max_depth in 102 | let res_list = loop_depths min_depth max_depth min_depth in 103 | let res_list = List.rev res_list in 104 | print_results res_list ; 105 | Print.string "long lived tree of depth " ; 106 | Print.int max_depth ; 107 | Print.string "\t check: " ; 108 | Print.int (check long_lived_tree) ; 109 | Print.newline() 110 | 111 | end 112 | -------------------------------------------------------------------------------- /test/shootout/bintree_2.lml: -------------------------------------------------------------------------------- 1 | module Triplet = struct 2 | type ('a, 'b, 'c) t = T of 'a * 'b * 'c 3 | end 4 | 5 | module Tree = struct 6 | 7 | type t = 8 | | Empty 9 | | Node of t * int * t 10 | 11 | val make: int * int -> t 12 | let make i depth = 13 | if depth = 0 14 | then 15 | Node Empty i Empty 16 | else 17 | let i2 = 2 * i in 18 | let depth = depth - 1 in 19 | let left = make (i2 - 1) depth in 20 | let right = make i2 depth in 21 | Node left i right 22 | 23 | val check: t -> int 24 | let check t = 25 | match t with 26 | | Empty -> 0 27 | | Node l i r -> i + check l - check r 28 | 29 | end 30 | 31 | module CheckMake = struct 32 | 33 | type private env = { 34 | depth : int; 35 | last : int; 36 | acc : int; 37 | } 38 | 39 | val private loop: env * int -> int 40 | let loop env i = 41 | if i > env.last 42 | then 43 | let res = env.acc in 44 | free env; 45 | res 46 | else 47 | let fst = Tree.check (Tree.make i env.depth) in 48 | let snd = Tree.check (Tree.make (0-i) env.depth) in 49 | let env = { env with acc = env.acc + fst + snd } in 50 | loop env (i+1) 51 | 52 | val go: int * int -> int 53 | let go d niter = 54 | let env = { depth = d; last = niter; acc = 0 } in 55 | loop env 1 56 | 57 | end 58 | 59 | module Main = struct 60 | 61 | (* This should be replaced by << soon *) 62 | val lsl: int * int -> int 63 | let lsl x y = 64 | if y <= 0 then x else 2*lsl x (y-1) 65 | 66 | type acc = (int, int, int) Triplet.t List.t 67 | 68 | val private loop1: int * int * int * int * int * int * acc 69 | -> acc 70 | let loop1 min_depth max_depth d threads i iend acc = 71 | if i > iend 72 | then acc 73 | else begin 74 | let dv = d + (i * 2) in 75 | let niter = lsl 1 (max_depth - dv + min_depth) in 76 | let c = CheckMake.go d niter in 77 | let acc = Triplet.T (dv, niter, c) :: acc in 78 | loop1 min_depth max_depth d threads (i+1) iend acc 79 | end 80 | 81 | val private loop_depths: int * int * int -> acc 82 | let loop_depths min_depth max_depth d = 83 | let last = ((max_depth - d) / 2 + 1) - 1 in 84 | let threads = 2 in 85 | loop1 min_depth max_depth d threads 0 last List.Empty 86 | 87 | val debug: 'a obs #-> unit = "liml_debug" 88 | 89 | val private print_results: acc -> unit 90 | let print_results l = 91 | match l with 92 | | List.Empty -> () 93 | | List.Cons (Triplet.T (d, niter, c)) rl -> 94 | Print.int (2 * niter); 95 | Print.string "\t trees of depth "; 96 | Print.int d; 97 | Print.string "\t check: "; 98 | Print.int c; 99 | Print.newline(); 100 | print_results rl 101 | 102 | val main: unit -> unit 103 | let main() = 104 | let min_depth = 4 in 105 | let max_depth = 20 in 106 | let stretch_depth = max_depth + 1 in 107 | let c = Tree.check (Tree.make 0 stretch_depth) in 108 | Print.string "stretch tree of depth "; 109 | Print.int stretch_depth; 110 | Print.string "\t check: "; 111 | Print.int c; 112 | Print.newline(); 113 | let long_lived_tree = Tree.make 0 max_depth in 114 | let res_list = loop_depths min_depth max_depth min_depth in 115 | let res_list = List.rev res_list in 116 | print_results res_list; 117 | Print.string "long lived tree of depth "; 118 | Print.int max_depth; 119 | Print.string "\t check: "; 120 | Print.int (Tree.check long_lived_tree); 121 | Print.newline() 122 | 123 | end 124 | -------------------------------------------------------------------------------- /test/shootout/bintree_main.c: -------------------------------------------------------------------------------- 1 | 2 | int main(){ 3 | BinaryTree_main() ; 4 | return 0 ; 5 | } 6 | -------------------------------------------------------------------------------- /test/shootout/custom_lib.c: -------------------------------------------------------------------------------- 1 | #include 2 | double float_of_int(int x){ return (double)x ; } 3 | int lsl(int x, int y){ return (x << y) ; } 4 | int land(int x, int y) { return (x & y) ; } 5 | void debug(void* p) { printf("%p\n", p) ; } 6 | void* magic(void* p) { return p; } 7 | void magic2(void* p) { return ; } 8 | -------------------------------------------------------------------------------- /test/shootout/fankuch.lml: -------------------------------------------------------------------------------- 1 | 2 | module Main = struct 3 | 4 | val land: int * int #-> int = "land" 5 | val lsl: int * int #-> int = "lsl" 6 | val debug: 'a obs #-> unit = "debug" 7 | 8 | (** Flip the front [n] pancakes of [a]. *) 9 | val private flip: int * int array * int * int -> int array 10 | let flip n a i iend = 11 | if i > iend 12 | then a 13 | else begin 14 | let tmp = a.(i) in 15 | let k = n - i in 16 | a.(i) <- a.(k) ; 17 | a.(k) <- tmp ; 18 | flip n a (i+1) iend 19 | end 20 | 21 | (** Count the number of flips so that pancake 0 is at index 0. *) 22 | val private count: int * int array -> int * int array 23 | let count c ary = 24 | let z = ary.(0) in 25 | if z = 0 then c, ary 26 | else begin 27 | let ary = flip z ary 0 (z/2) in 28 | let c = c + 1 in 29 | count c ary 30 | end 31 | 32 | (** Rotate the first [n] pancakes of [a]. *) 33 | val private rotate: int * int array -> int array 34 | let rotate n a = 35 | let t = a.(0) in 36 | let m = n - 1 in 37 | let a = rotate_loop a 1 m in 38 | a.(m) <- t ; 39 | a 40 | 41 | val private rotate_loop: int array * int * int -> int array 42 | let rotate_loop a i m = 43 | if i > m 44 | then a 45 | else begin 46 | a.(i-1) <- a.(i) ; 47 | rotate_loop a (i+1) m 48 | end 49 | 50 | type env = { 51 | csum: int ; 52 | m: int ; 53 | n: int ; 54 | num: int ; 55 | perm: int array ; 56 | copy: int array ; 57 | ht: int ; 58 | } 59 | 60 | val private acopy: int array obs * int array * int -> int array 61 | let acopy t1 t2 i = 62 | if i < 0 63 | then t2 64 | else begin 65 | t2.(i) <- t1.(i) ; 66 | acopy t1 t2 (i-1) 67 | end 68 | 69 | val private do_iter: env -> env 70 | let do_iter env = 71 | if env.ht = 1 then begin 72 | let { env ; ~copy } = env in 73 | let copy = acopy env.perm copy (Array.length env.perm - 1) in 74 | let c, copy = count 0 copy in 75 | let csum = env.csum + c * (1 - (lsl (land env.num 1) 1)) in 76 | let m = if c > env.m then c else env.m in 77 | let env = { env with ~csum ; ~m ; num = env.num + 1 ; ~copy } in 78 | env 79 | end else do_iter_loop env 1 80 | 81 | val private do_iter_loop: env * int -> env 82 | let do_iter_loop env i = 83 | if i > env.ht 84 | then env 85 | else 86 | let env = { env with ht = env.ht - 1 } in 87 | let { ~perm ; env } = do_iter env in 88 | let env = { env with ht = env.ht + 1 } in 89 | let perm = rotate env.ht perm in 90 | do_iter_loop { env with ~perm } (i+1) 91 | 92 | val private init_perm: int array * int -> int array 93 | let init_perm t n = 94 | if n < 0 95 | then t 96 | else begin 97 | t.(n) <- n ; 98 | init_perm t (n-1) 99 | end 100 | 101 | (** Call [f] on each permutation of [n] numbers in order. *) 102 | val private iter_perms: int -> env 103 | let iter_perms n = 104 | let perm = Array.imake n 0 in 105 | let perm = init_perm perm (n-1) in 106 | let copy = Array.imake n 0 in 107 | let csum = 0 in 108 | let m = 0 in 109 | let env = { 110 | csum = csum ; 111 | m = m ; 112 | n = n ; 113 | num = 0 ; 114 | perm = perm ; 115 | copy = copy ; 116 | ht = n ; 117 | } in 118 | do_iter env 119 | 120 | val main: unit -> unit 121 | let main () = 122 | let n = 10 in 123 | let env = iter_perms n in 124 | Print.int env.csum ; 125 | Print.newline() ; 126 | Print.string "Pfannkuchen(" ; 127 | Print.int env.n ; 128 | Print.string ") = " ; 129 | Print.int env.m ; 130 | Print.newline() ; 131 | let { env ; ~perm ; ~copy } = env in 132 | Array.irelease perm ; 133 | Array.irelease copy ; 134 | free env 135 | 136 | 137 | end 138 | -------------------------------------------------------------------------------- /test/shootout/fankuch_main.c: -------------------------------------------------------------------------------- 1 | int main(){ 2 | Fankuch_main() ; 3 | return 0 ; 4 | } 5 | -------------------------------------------------------------------------------- /test/shootout/nbody.lml: -------------------------------------------------------------------------------- 1 | 2 | module Planet = struct 3 | 4 | type t = { x: float; y: float; z: float; 5 | vx: float; vy: float; vz: float; 6 | mass: float } 7 | 8 | type env = { 9 | pi: float ; 10 | solar_mass: float ; 11 | days_per_year: float ; 12 | } 13 | 14 | val free_t: t #-> unit 15 | let free_t p = free p 16 | 17 | val set_t: t Array.t * int * t -> t Array.t 18 | let set_t t i x = 19 | let t, dummy = Array.swap t i x in 20 | free_t dummy ; 21 | t 22 | 23 | val advance_loop2: float * t Array.t * t * int * int -> t Array.t * t 24 | let advance_loop2 dt bodies b j jend = 25 | if j >= jend 26 | then bodies, b 27 | else 28 | let bodies, b2 = Array.swap bodies j None in 29 | match b2 with 30 | | None -> bodies, b 31 | | Some b2 -> 32 | let dx = b.x - b2.x in 33 | let dy = b.y - b2.y in 34 | let dz = b.z - b2.z in 35 | let dist2 = dx * dx + dy * dy + dz * dz in 36 | let mag = dt / (dist2 * Math.sqrt(dist2)) in 37 | let b = { b with 38 | vx = b.vx - dx * b2.mass * mag; 39 | vy = b.vy - dy * b2.mass * mag; 40 | vz = b.vz - dz * b2.mass * mag } in 41 | let b2 = { b2 with 42 | vx = b2.vx + dx * b.mass * mag; 43 | vy = b2.vy + dy * b.mass * mag; 44 | vz = b2.vz + dz * b.mass * mag } in 45 | let bodies = set_t bodies j b2 in 46 | advance_loop2 dt bodies b (j+1) jend 47 | 48 | val advance_loop1: float * t Array.t * int * int -> t Array.t 49 | let rec advance_loop1 dt bodies i iend = 50 | if i >= iend 51 | then bodies 52 | else 53 | let bodies, b = Array.swap bodies i None in 54 | match b with 55 | | None -> bodies 56 | | Some b -> 57 | let size = Array.length !bodies in 58 | let bodies, b = advance_loop2 dt bodies b (i+1) size in 59 | let bodies = set_t bodies i b in 60 | advance_loop1 dt bodies (i+1) iend 61 | 62 | 63 | val advance_loop3: float * t Array.t * int * int -> t Array.t 64 | let rec advance_loop3 dt bodies i iend = 65 | if i >= iend 66 | then bodies 67 | else 68 | let bodies, b = Array.swap bodies i None in 69 | match b with 70 | | None -> bodies 71 | | Some b -> 72 | let b = { b with 73 | x = b.x + dt * b.vx; 74 | y = b.y + dt * b.vy; 75 | z = b.z + dt * b.vz } in 76 | let bodies = set_t bodies i b in 77 | advance_loop3 dt bodies (i+1) iend 78 | 79 | val advance: t Array.t * float -> t Array.t 80 | let advance bodies dt = 81 | let size = Array.length !bodies in 82 | let bodies = advance_loop1 dt bodies 0 size in 83 | let bodies = advance_loop3 dt bodies 0 size in 84 | bodies 85 | 86 | 87 | val energy_loop1: t Array.t obs * t obs * float * int * int -> float 88 | let rec energy_loop1 bodies b e j jend = 89 | if j >= jend 90 | then e 91 | else 92 | match Array.get bodies j with 93 | | None -> e 94 | | Some b2 -> 95 | let dx = b.x - b2.x in 96 | let dy = b.y - b2.y in 97 | let dz = b.z - b2.z in 98 | let distance = Math.sqrt(dx * dx + dy * dy + dz * dz) in 99 | let e = e - (b.mass * b2.mass) / distance in 100 | energy_loop1 bodies b e (j+1) jend 101 | 102 | 103 | val energy_loop2: t Array.t obs * float * int * int -> float 104 | let energy_loop2 bodies e i iend = 105 | if i >= iend 106 | then e 107 | else 108 | match Array.get bodies i with 109 | | None -> e 110 | | Some b -> 111 | let e = e + 0.5 * b.mass * (b.vx * b.vx + b.vy * b.vy + b.vz * b.vz) in 112 | let e = energy_loop1 bodies b e (i+1) iend in 113 | energy_loop2 bodies e (i+1) iend 114 | 115 | 116 | val energy: t Array.t obs -> float 117 | let energy bodies = 118 | let e = 0.0 in 119 | let size = Array.length bodies in 120 | energy_loop2 bodies e 0 size 121 | 122 | val offset_loop: t Array.t obs * float * float * float * int * int 123 | -> float * float * float 124 | let rec offset_loop bodies px py pz i iend = 125 | if i >= iend 126 | then px, py, pz 127 | else 128 | match Array.get bodies i with 129 | | None -> px, py, pz 130 | | Some bi -> 131 | let px = px + bi.vx * bi.mass in 132 | let py = py + bi.vy * bi.mass in 133 | let pz = pz + bi.vz * bi.mass in 134 | offset_loop bodies px py pz (i+1) iend 135 | 136 | val offset_momentum: env obs * t Array.t -> t Array.t 137 | let offset_momentum env bodies = 138 | let px = 0.0 in 139 | let py = 0.0 in 140 | let pz = 0.0 in 141 | let size = Array.length !bodies in 142 | let px, py, pz = offset_loop !bodies px py pz 0 size in 143 | let bodies, b0 = Array.swap bodies 0 None in 144 | match b0 with 145 | | None -> bodies 146 | | Some b0 -> 147 | let b0 = { b0 with 148 | vx = 0.0 - px / env.solar_mass; 149 | vy = 0.0 - py / env.solar_mass; 150 | vz = 0.0 - pz / env.solar_mass } in 151 | let bodies = set_t bodies 0 b0 in 152 | bodies 153 | 154 | end 155 | 156 | module Main = struct 157 | 158 | val main_loop: Planet.t Array.t * int * int -> Planet.t Array.t 159 | let rec main_loop bodies i n = 160 | if i > n 161 | then bodies 162 | else begin 163 | bodies := Planet.advance bodies 0.01 ; 164 | main_loop bodies (i+1) n 165 | end 166 | 167 | val main: unit #-> unit 168 | let main() = 169 | let pi = 3.141592653589793 in 170 | let env = { 171 | Planet.pi = pi ; 172 | Planet.solar_mass = 4.0 * pi * pi ; 173 | Planet.days_per_year = 365.24 ; 174 | } in 175 | let n = 2000 in 176 | let jupiter = { Planet.x = 4.84143144246472090; 177 | Planet.y = 0.0 -1.16032004402742839; 178 | Planet.z = 0.0 - 0.103622044471123109; 179 | Planet.vx = 0.00166007664274403694 * env.Planet.days_per_year; 180 | Planet.vy = 0.00769901118419740425 * env.Planet.days_per_year; 181 | Planet.vz = 0.0000690460016972063023 * env.Planet.days_per_year; 182 | Planet.mass = 0.000954791938424326609 * env.Planet.solar_mass; } in 183 | 184 | let saturn = { Planet.x = 8.34336671824457987; 185 | Planet.y = 4.12479856412430479; 186 | Planet.z = 0.403523417114321381; 187 | Planet.vx = 0.0 - 0.00276742510726862411 * env.Planet.days_per_year; 188 | Planet.vy = 0.00499852801234917238 * env.Planet.days_per_year; 189 | Planet.vz = 0.0000230417297573763929 * env.Planet.days_per_year; 190 | Planet.mass = 0.000285885980666130812 * env.Planet.solar_mass; } in 191 | 192 | let uranus = { Planet.x = 12.8943695621391310; 193 | Planet.y = 0.0 - 15.1111514016986312; 194 | Planet.z = 0.0 - 0.223307578892655734; 195 | Planet.vx = 2.96460137564761618 * env.Planet.days_per_year; 196 | Planet.vy = 2.37847173959480950 * env.Planet.days_per_year; 197 | Planet.vz = 0.0 -2.96589568540237556 * env.Planet.days_per_year; 198 | Planet.mass = 4.36624404335156298 * env.Planet.solar_mass; } in 199 | 200 | let neptune = { 201 | Planet.x = 1.53796971148509165; 202 | Planet.y = 0.0 -2.59193146099879641; 203 | Planet.z = 1.79258772950371181; 204 | Planet.vx = 2.68067772490389322 * env.Planet.days_per_year; 205 | Planet.vy = 1.62824170038242295 * env.Planet.days_per_year; 206 | Planet.vz = 0.0 -9.51592254519715870 * env.Planet.days_per_year; 207 | Planet.mass = 5.15138902046611451 * env.Planet.solar_mass; } in 208 | 209 | let sun = { Planet.x = 0.0; 210 | Planet.y = 0.0; 211 | Planet.z = 0.0; 212 | Planet.vx = 0.0; 213 | Planet.vy = 0.0; 214 | Planet.vz = 0.0; 215 | Planet.mass = env.Planet.solar_mass; } in 216 | let bodies = Array.fmake 5 in 217 | bodies := Planet.set_t bodies 0 sun ; 218 | bodies := Planet.set_t bodies 1 jupiter ; 219 | bodies := Planet.set_t bodies 2 saturn ; 220 | bodies := Planet.set_t bodies 3 uranus ; 221 | bodies := Planet.set_t bodies 4 neptune ; 222 | bodies := Planet.offset_momentum !env bodies; 223 | Print.float (Planet.energy !bodies); 224 | bodies := main_loop bodies 1 n; 225 | Print.float (Planet.energy !bodies) ; 226 | Array.release bodies Planet.free_t ; 227 | free env 228 | 229 | end 230 | -------------------------------------------------------------------------------- /test/shootout/parBintree.lml: -------------------------------------------------------------------------------- 1 | module Triplet = struct 2 | type ('a, 'b, 'c) t = T of 'a * 'b * 'c 3 | end 4 | 5 | module Pair = struct 6 | type ('a, 'b) t = P of 'a * 'b 7 | end 8 | 9 | module Tree = struct 10 | 11 | type t = 12 | | Empty 13 | | Node of t * int * t 14 | 15 | val make: int * int -> t 16 | let make i depth = 17 | if depth = 0 18 | then 19 | Node Empty i Empty 20 | else 21 | let i2 = 2 * i in 22 | let depth = depth - 1 in 23 | let left = make (i2 - 1) depth in 24 | let right = make i2 depth in 25 | Node left i right 26 | 27 | val check: t -> int 28 | let check t = 29 | match t with 30 | | Empty -> 0 31 | | Node l i r -> i + check l - check r 32 | 33 | end 34 | 35 | module CheckMake = struct 36 | 37 | type private env = { 38 | depth : int; 39 | last : int; 40 | acc : int; 41 | } 42 | 43 | val private loop: env * int -> int 44 | let loop env i = 45 | if i > env.last 46 | then 47 | let res = env.acc in 48 | free env; 49 | res 50 | else 51 | let fst = Tree.check (Tree.make i env.depth) in 52 | let snd = Tree.check (Tree.make (0-i) env.depth) in 53 | let env = { env with acc = env.acc + fst + snd } in 54 | loop env (i+1) 55 | 56 | val go: (int, int) Pair.t #-> int 57 | let go x = 58 | match x with 59 | | Pair.P d niter -> 60 | let env = { depth = d; last = niter; acc = 0 } in 61 | loop env 1 62 | 63 | end 64 | 65 | module Main = struct 66 | 67 | (* This should be replaced by << soon *) 68 | val lsl: int * int -> int 69 | let lsl x y = 70 | if y <= 0 then x else 2*lsl x (y-1) 71 | 72 | type acc = (int, int, int Future.t) Triplet.t List.t 73 | 74 | val private loop1: int * int * int * int * int * int * acc 75 | -> acc 76 | let loop1 min_depth max_depth d threads i iend acc = 77 | if i > iend 78 | then acc 79 | else begin 80 | let dv = d + (i * 2) in 81 | let niter = lsl 1 (max_depth - dv + min_depth) in 82 | let c = Future.make CheckMake.go (Pair.P d niter) in 83 | let acc = Triplet.T (dv, niter, c) :: acc in 84 | loop1 min_depth max_depth d threads (i+1) iend acc 85 | end 86 | 87 | val private loop_depths: int * int * int -> acc 88 | let loop_depths min_depth max_depth d = 89 | let last = ((max_depth - d) / 2 + 1) - 1 in 90 | let threads = 2 in 91 | loop1 min_depth max_depth d threads 0 last List.Empty 92 | 93 | val debug: 'a obs #-> unit = "liml_debug" 94 | 95 | val private print_results: acc -> unit 96 | let print_results l = 97 | match l with 98 | | List.Empty -> () 99 | | List.Cons (Triplet.T (d, niter, c)) rl -> 100 | Print.int (2 * niter); 101 | Print.string "\t trees of depth "; 102 | Print.int d; 103 | Print.string "\t check: "; 104 | Print.int (Future.wait c); 105 | Print.newline(); 106 | print_results rl 107 | 108 | val main: unit -> unit 109 | let main() = 110 | let min_depth = 4 in 111 | let max_depth = 20 in 112 | let stretch_depth = max_depth + 1 in 113 | let c = Tree.check (Tree.make 0 stretch_depth) in 114 | Print.string "stretch tree of depth "; 115 | Print.int stretch_depth; 116 | Print.string "\t check: "; 117 | Print.int c; 118 | Print.newline(); 119 | let long_lived_tree = Tree.make 0 max_depth in 120 | let res_list = loop_depths min_depth max_depth min_depth in 121 | let res_list = List.rev res_list in 122 | print_results res_list; 123 | Print.string "long lived tree of depth "; 124 | Print.int max_depth; 125 | Print.string "\t check: "; 126 | Print.int (Tree.check long_lived_tree); 127 | Print.newline() 128 | 129 | end 130 | -------------------------------------------------------------------------------- /test/shootout/spectral.lml: -------------------------------------------------------------------------------- 1 | 2 | module Main = struct 3 | 4 | module FA = Array 5 | 6 | val private eval_A: int * int -> float 7 | let eval_A i j = 1.0 / Math.float_of_int ((i+j)*(i+j+1)/2+i+1) 8 | 9 | val private eval_A_times_u: int * float array obs * float array -> float array 10 | let eval_A_times_u n u v = 11 | let n = n - 1 in 12 | eval_A_times_u_loop u v 0 n 13 | 14 | val private eval_A_times_u_loop: float array obs * float array * int * int -> float array 15 | let eval_A_times_u_loop u v i n = 16 | if i > n 17 | then v 18 | else 19 | let vi = eval_A_times_u_loop2 u !v i 0 n 0.0 in 20 | let v = FA.set v i vi in 21 | eval_A_times_u_loop u v (i+1) n 22 | 23 | val private eval_A_times_u_loop2: float array obs * float array obs * int * int * int * float -> float 24 | let eval_A_times_u_loop2 u v i j n vi = 25 | if j > n 26 | then vi 27 | else 28 | let uj = FA.get u j in 29 | let vi = vi + eval_A i j * uj in 30 | eval_A_times_u_loop2 u v i (j+1) n vi 31 | 32 | val private eval_At_times_u: int * float array obs * float array -> float array 33 | let eval_At_times_u n u v = 34 | let n = n - 1 in 35 | eval_At_times_u_loop u v 0 n 36 | 37 | val private eval_At_times_u_loop: float array obs * float array * int * int -> float array 38 | let eval_At_times_u_loop u v i n = 39 | if i > n 40 | then v 41 | else 42 | let vi = eval_At_times_u_loop2 u !v i 0 n 0.0 in 43 | let v = FA.set v i vi in 44 | eval_At_times_u_loop u v (i+1) n 45 | 46 | val private eval_At_times_u_loop2: float array obs * float array obs * int * int * int * float -> float 47 | let eval_At_times_u_loop2 u v i j n vi = 48 | if j > n 49 | then vi 50 | else 51 | let uj = FA.get u j in 52 | let vi = vi + eval_A j i * uj in 53 | eval_At_times_u_loop2 u v i (j+1) n vi 54 | 55 | val private eval_AtA_times_u: int * float array obs * float array -> float array 56 | let eval_AtA_times_u n u v = 57 | let w = FA.fmake n 0.0 in 58 | let w = eval_A_times_u n u w in 59 | let v = eval_At_times_u n !w v in 60 | FA.frelease w ; 61 | v 62 | 63 | val private main_loop1: int * float array * float array * int -> float array * float array 64 | let main_loop1 n u v i = 65 | if i > 9 66 | then u, v 67 | else 68 | let v = eval_AtA_times_u n !u v in 69 | let u = eval_AtA_times_u n !v u in 70 | main_loop1 n u v (i+1) 71 | 72 | val private main_loop2: float array obs * float array obs * int * int * float * float -> float * float 73 | let main_loop2 u v n i vv vBv = 74 | if i > n-1 75 | then vv, vBv 76 | else 77 | let vi = FA.get v i in 78 | let vv = vv + vi * vi in 79 | let vBv = vBv + FA.get u i * vi in 80 | main_loop2 u v n (i+1) vv vBv 81 | 82 | val main: unit -> unit 83 | let main () = 84 | let n = 2000 in 85 | let u = FA.fmake n 1.0 in 86 | let v = FA.fmake n 0.0 in 87 | let u, v = main_loop1 n u v 0 in 88 | let vv, vBv = main_loop2 !u !v n 0 0.0 0.0 in 89 | FA.frelease u ; 90 | FA.frelease v ; 91 | Print.float (Math.sqrt (vBv / vv)) ; 92 | Print.newline() 93 | end 94 | -------------------------------------------------------------------------------- /test/shootout/spectral_main.c: -------------------------------------------------------------------------------- 1 | 2 | int main(){ 3 | SpectralNorm_main() ; 4 | return 0 ; 5 | } 6 | -------------------------------------------------------------------------------- /test/test_future.lml: -------------------------------------------------------------------------------- 1 | 2 | module TestFuture = struct 3 | 4 | (* Dummy thread doing nothing *) 5 | val run: IntBox.t #-> IntBox.t 6 | let run x = x 7 | 8 | val show: IntBox.t -> unit 9 | let show x = 10 | Print.int (IntBox.get (obs x)) ; 11 | IntBox.release x ; 12 | Print.newline() 13 | 14 | val main: unit #-> unit 15 | let main () = 16 | let b = IntBox.make 23 in 17 | let b = Future.make run b in 18 | show (Future.wait b) 19 | 20 | end 21 | -------------------------------------------------------------------------------- /test/test_share.lml: -------------------------------------------------------------------------------- 1 | 2 | 3 | module TestShare = struct 4 | 5 | val show: IntBox.t obs -> unit 6 | let show x = 7 | Print.int (IntBox.get x) ; 8 | Print.newline() 9 | 10 | val release: IntBox.t option -> unit 11 | let release x = 12 | match x with 13 | | None -> () 14 | | Some v -> IntBox.release v 15 | 16 | val main: unit #-> unit 17 | let main () = 18 | let b = IntBox.make 22 in 19 | let b1 = Share.make b in 20 | let b2 = Share.clone (obs b1) in 21 | show (Share.visit (obs b1)) ; 22 | show (Share.visit (obs b2)) ; 23 | release (Share.release b1) ; 24 | release (Share.release b2) 25 | end 26 | -------------------------------------------------------------------------------- /test/unit/go.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | for i in test*.lml ; do 4 | echo "RUNNING: $i" ; 5 | ../../liml $i -main Test ; 6 | done 7 | -------------------------------------------------------------------------------- /test/unit/monad.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | module Maybe = struct 4 | 5 | type 'a t = 6 | | Nothing 7 | | Just of 'a 8 | 9 | val bind: 'a t * ('a -> 'b t) -> 'b t 10 | let bind t f = 11 | match t with 12 | | Nothing -> Nothing 13 | | Just x -> f x 14 | 15 | val return: 'a -> 'a t 16 | let return x = Just x 17 | 18 | end 19 | 20 | *) 21 | 22 | module ContinuationMonad = struct 23 | 24 | type ('a, 'b) t = 'a -> 'b 25 | 26 | val bind: (('a -> 'b) -> 'b) * ('a * ('c -> 'b) -> 'b) * ('c -> 'b) -> 'b 27 | let bind c f k = c (fun (t: 'l) -> f t k) 28 | 29 | val return: 'a * ('a -> 'b) -> 'b 30 | let return t f = f t 31 | 32 | end 33 | 34 | module Lazy = struct 35 | 36 | type 'a t = unit -> 'a 37 | 38 | val force: 'a t -> 'a 39 | let force f = f() 40 | end 41 | 42 | module LList = struct 43 | 44 | type 'a t = 45 | | Empty 46 | | Cons of 'a * 'a t Lazy.t 47 | 48 | val make: int -> int t 49 | let make n = 50 | if n = 0 51 | then Empty 52 | else Cons n (fun () -> make (n-1)) 53 | end 54 | 55 | -------------------------------------------------------------------------------- /test/unit/test_array1.lml: -------------------------------------------------------------------------------- 1 | 2 | module Test = struct 3 | 4 | val debug: 'a obs #-> unit = "debug" 5 | val pint: int #-> unit = "print_int" 6 | val pstring: string #-> unit = "print_string" 7 | val pnewline: unit #-> unit = "print_newline" 8 | 9 | val test_int: unit -> int * int * int 10 | let test_int () = 11 | let t = Array.imake 10 1 in 12 | let x1 = t.(3) in 13 | x2 := t.(0-1) ; 14 | debug !t ; 15 | x3 := t.(10) ; 16 | Array.irelease t ; 17 | x1, x2, x3 18 | 19 | val test_float: unit -> float * float * float 20 | let test_float () = 21 | let t = Array.fmake 10 1.0 in 22 | let x1 = t.(3) in 23 | x2 := t.(0-1) ; 24 | x3 := t.(10) ; 25 | Array.frelease t ; 26 | x1, x2, x3 27 | 28 | val main: unit -> unit 29 | let main() = 30 | pstring "Test Array1: " ; 31 | let x1, x2, x3 = test_int () in 32 | let y1, y2, y3 = test_float () in 33 | if x1 = 1 && x2 = 0 && x3 = 0 34 | && y1 = 1.0 && y2 = 0.0 && y3 = 0.0 35 | then (pstring "OK" ; pnewline()) 36 | else (pstring "KO" ; pnewline()) 37 | end 38 | -------------------------------------------------------------------------------- /test/unit/test_array2.lml: -------------------------------------------------------------------------------- 1 | 2 | module Test = struct 3 | 4 | val private sum_down_loop: int array obs * int * int -> int 5 | let sum_down_loop t i acc = 6 | if i < 0 7 | then acc 8 | else (acc := acc + t.(i) ; 9 | sum_down_loop t (i-1) acc) 10 | 11 | val sum_down: int array obs -> int 12 | let sum_down t = 13 | sum_down_loop t (Array.length t - 1) 0 14 | 15 | val private sum_up_loop: int array obs * int * int * int -> int 16 | let sum_up_loop t size i acc = 17 | if i >= size 18 | then acc 19 | else (acc := acc + t.(i) ; 20 | sum_up_loop t size (i+1) acc) 21 | 22 | val sum_up: int array obs -> int 23 | let sum_up t = 24 | let size = Array.length t in 25 | sum_up_loop t size 0 0 26 | 27 | val private swap_loop: 'a array * 'a * int * int -> 'a array * 'a 28 | let swap_loop t dumb i j = 29 | if i >= j 30 | then t, dumb 31 | else 32 | let t, ti = Array.swap t i dumb in 33 | let t, tj = Array.swap t j ti in 34 | let t, dumb = Array.swap t i tj in 35 | swap_loop t dumb (i+1) (j-1) 36 | 37 | val swap: 'a array * 'a -> 'a array * 'a 38 | let swap t x = 39 | swap_loop t x 0 (Array.length !t - 1) 40 | 41 | val init: int -> int 42 | let init x = x 43 | 44 | val free_int: int -> unit 45 | let free_int _ = () 46 | 47 | val main: unit -> unit 48 | let main() = 49 | Print.string "Test Array2: " ; 50 | let t = Array.init 10 init in 51 | let n1 = sum_up !t in 52 | let n2 = sum_down !t in 53 | let t, _ = swap t 0 in 54 | let n3 = sum_up !t in 55 | Array.release free_int t ; 56 | if n1 = 45 && n2 = 45 && n3 = 45 57 | then (Print.string "OK" ; Print.newline()) 58 | else (Print.string "KO" ; Print.newline()) 59 | end 60 | 61 | -------------------------------------------------------------------------------- /test/unit/test_basic.lml: -------------------------------------------------------------------------------- 1 | 2 | 3 | module Test1 = struct 4 | 5 | val f: int -> int 6 | let f x = x+1 7 | 8 | end 9 | 10 | module Test = struct 11 | 12 | val init: int -> int 13 | let init x = x 14 | 15 | val nothing: int -> unit 16 | let nothing _ = () 17 | 18 | val add1: int -> int 19 | let add1 x = x+1 20 | 21 | val app: ('a -> 'a) * 'a -> 'a 22 | let app f x = f x 23 | 24 | val main: unit -> unit 25 | let main() = 26 | let t = Array.init 10 init in 27 | t.(0) <- 23 ; 28 | let x = t.(0) in 29 | Print.int (Array.length !t) ; 30 | Print.newline() ; 31 | Array.release nothing t ; 32 | Print.int x ; 33 | Print.newline() ; 34 | x := 2 ; 35 | Print.int (app add1 x) ; 36 | Print.newline() 37 | 38 | end 39 | -------------------------------------------------------------------------------- /test/unit/test_char.lml: -------------------------------------------------------------------------------- 1 | 2 | 3 | module Test = struct 4 | 5 | val main: unit -> unit 6 | let main() = 7 | let c = '\t' in 8 | Print.char c ; 9 | () 10 | end 11 | -------------------------------------------------------------------------------- /test/unit/test_closure.lml: -------------------------------------------------------------------------------- 1 | 2 | module Test = struct 3 | 4 | val main: unit -> (int -> 'a List.t) 5 | let main () = 6 | let n = [] in 7 | fun (x: int) -> n 8 | end 9 | 10 | 11 | -------------------------------------------------------------------------------- /test/unit/test_core.lml: -------------------------------------------------------------------------------- 1 | 2 | module Test = struct 3 | 4 | val pp: int -> unit 5 | let pp n = 6 | Print.int n ; 7 | Print.newline() 8 | 9 | val main: unit -> unit 10 | let main() = 11 | (* Test comparison functions *) 12 | let b = true = true in 13 | let b = true = false in 14 | let b = 0 = 0 in 15 | let b = 1.0 = 1.0 in 16 | let b = 'A' < 'Z' in 17 | let s1 = String.make "hello" in 18 | let s2 = String.make "hell" in 19 | let c = String.compare !s1 !s2 in 20 | String.release s1 ; 21 | String.release s2 ; 22 | Print.int c ; 23 | let b = not true in 24 | Print.int (if b then 1 else 0) ; 25 | let n1 = 23 % 10 in 26 | let v = (-1) in 27 | let n1 = Pervasives.abs v in 28 | Print.newline() ; 29 | Print.int n1 ; 30 | let n1 = 1 in 31 | let n2 = 2 in 32 | let n = n1 & n2 in 33 | pp n ; 34 | () 35 | 36 | end 37 | 38 | -------------------------------------------------------------------------------- /test/unit/test_eval.lml: -------------------------------------------------------------------------------- 1 | 2 | module Test = struct 3 | 4 | val rev: 'a List.t * 'a List.t -> 'a List.t 5 | let rev acc l = 6 | match l with 7 | | [] -> acc 8 | | x :: rl -> rev (x :: acc) rl 9 | 10 | val main: unit -> int List.t 11 | let main() = 12 | rev [] [1;2;3] 13 | end 14 | -------------------------------------------------------------------------------- /test/unit/test_float.lml: -------------------------------------------------------------------------------- 1 | 2 | module Test = struct 3 | 4 | val add1: float #-> float 5 | let add1 x = x + 1.0 6 | 7 | val app: ('a #-> 'a) * 'a -> 'a 8 | let app f x = f x 9 | 10 | val main: unit -> unit 11 | let main() = 12 | x0 := Math.sin 1.0 ; 13 | x1 := Math.sqrt 2.0 ; 14 | x2 := app Math.sqrt 2.0 ; 15 | x3 := app add1 2.0 ; 16 | if x0 <> 0.0 && x1 <> 0.0 && x2 <> 0.0 17 | && x3 <> 0.0 18 | then (Print.string "OK" ; Print.newline()) 19 | else (Print.string "KO" ; Print.newline()) 20 | 21 | 22 | end 23 | -------------------------------------------------------------------------------- /test/unit/test_linear.lml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | module List = struct 5 | 6 | type 'a t = 7 | | Empty 8 | | Cons of 'a * 'a t 9 | 10 | val magic: 'a #-> unit = "debug" 11 | val magic_obs: 'a obs #-> unit = "debug" 12 | 13 | val map_acc: ('a * 'b -> 'a * 'c) obs * 'a * 'b t -> 'a * 'c t 14 | let map_acc f acc l = 15 | match l with 16 | | [] -> acc, [] 17 | | x :: rl -> 18 | let acc, x = f acc x in 19 | let acc, rl = map_acc f acc rl in 20 | acc, x :: rl 21 | 22 | val fac: ('a -> 'b) obs * int -> 'b 23 | let fac k n = 24 | if n <= 0 25 | then k 1 26 | else fac (!fun (res: int) -> k (n*res)) (n-1) 27 | 28 | (* 29 | val rev_append: 'a t * 'a t -> 'a t 30 | let rev_append acc l = 31 | match l with 32 | | [] -> acc 33 | | x :: rl -> rev_append (x :: acc) rl 34 | *) 35 | (* 36 | val f: 'a * 'a -> 'a 37 | let f x z = 38 | match !x with 39 | | y -> 40 | magic x ; 41 | magic_obs y ; 42 | z 43 | *) 44 | 45 | (* 46 | val f: 'a * 'a -> 'a 47 | let f x z = 48 | let u, v = x, !x in 49 | z 50 | *) 51 | 52 | (* 53 | val f: 'a * 'a -> 'a 54 | let f x y = 55 | let u = if true then !x else !y in 56 | let _ = u in 57 | x 58 | *) 59 | 60 | (* 61 | val f: 'a -> 'a obs 62 | let f x = 63 | let f = fun () -> !x in 64 | magic x ; 65 | f() 66 | *) 67 | 68 | (* 69 | val g: 'a obs -> unit = asm "" 70 | 71 | val f: 'a -> 'a 72 | let f x = 73 | let f = fun () -> g !x in 74 | magic x ; 75 | f() ; 76 | x 77 | *) 78 | (* 79 | val g: 'a obs * unit -> unit = asm "" 80 | 81 | val f: 'a -> 'a 82 | let f x = 83 | let f = partial g !x in 84 | magic x ; 85 | f() ; 86 | x 87 | *) 88 | 89 | (* 90 | val f: 'a -> unit 91 | let f x = 92 | let f = fun () -> !x in 93 | let t = fun () -> 94 | let _ = f() in 95 | let _ = x in 96 | () in 97 | magic x ; 98 | let _ = t() in 99 | () 100 | *) 101 | (* 102 | val f: 'a -> 'a 103 | let f x = 104 | let y, _ = x, !x in 105 | y 106 | *) 107 | 108 | (* 109 | val rev_append: 'a t -> 'a t 110 | let rev_append l = 111 | match l with 112 | | ((x :: (y :: rl as l1)) as l2) -> 113 | if true 114 | then x :: l1 115 | else (magic rl ; [y]) 116 | | l -> l 117 | *) 118 | 119 | (* 120 | val rev_append: 'a t -> 'a t 121 | let rev_append l = 122 | match l with 123 | | ((x :: (y :: rl as l1)) as l2) -> 124 | if true 125 | then x :: l1 126 | else if true 127 | then x :: y :: rl 128 | else 129 | let l = !rl in 130 | let f = fun () -> let _ = !rl in () in 131 | let z = magic l2 in 132 | f() ; [] 133 | | l -> l 134 | *) 135 | 136 | (* 137 | val rev_append: 'a t obs -> 'a t obs 138 | let rev_append l = 139 | match l with 140 | | (_ :: rl) as l -> l 141 | | l -> l 142 | *) 143 | 144 | (* 145 | val f1: 'a obs -> 'a obs 146 | let f1 l = l 147 | 148 | val f2: 'a -> 'a 149 | let f2 x = 150 | let x, y = x, !x in 151 | x 152 | *) 153 | 154 | (* 155 | val rev_append: 'a t -> unit 156 | let rev_append l = 157 | match l with 158 | | (x :: rl) as l -> 159 | let y = !l in 160 | magic x ; 161 | magic rl ; 162 | magic_obs y 163 | | l -> magic l 164 | *) 165 | 166 | (* 167 | val rev_append: 'a t -> 'a t 168 | let rev_append l = 169 | match l with 170 | | (x :: rl) as l -> rl 171 | | l -> l 172 | *) 173 | 174 | (* 175 | val rev_append: 'a t -> 'a t 176 | let rev_append l = 177 | match l with 178 | | ((x :: rl) as l) -> 179 | if true 180 | then (x :: rl) 181 | else l 182 | | l -> l 183 | *) 184 | 185 | end 186 | -------------------------------------------------------------------------------- /test/unit/test_list.lml: -------------------------------------------------------------------------------- 1 | 2 | module List = struct 3 | 4 | type 'a t = 5 | | Empty 6 | | Cons of 'a * 'a t 7 | 8 | val rev: 'a t * 'a t -> 'a t 9 | let rev acc l = 10 | match l with 11 | | [] -> acc 12 | | x :: rl -> rev (x :: acc) rl 13 | end 14 | -------------------------------------------------------------------------------- /test/unit/test_poly.lml: -------------------------------------------------------------------------------- 1 | 2 | module Test = struct 3 | 4 | val f: 'a -> 'a 5 | let f x = x 6 | 7 | val g: 'a -> 'a 8 | let g x = x 9 | 10 | val d: float -> float * float * float * float * float 11 | let d x = x, x, x, x, x 12 | 13 | val h: ('a -> 'a * 'a * 'a * 'a * 'a) * 'a -> 'a * 'a * 'a * 'a * 'a 14 | let h f x = f x 15 | 16 | val main: unit -> unit 17 | let main() = 18 | let _ = f 1 in 19 | let _ = f 1.0 in 20 | let x = f g in 21 | let _ = f "hello" in 22 | let x, _, _, _, y = h d 23.0 in 23 | let x, _, _, _, y = d 23.0 in 24 | Print.float x ; 25 | Print.float y ; 26 | () 27 | end 28 | -------------------------------------------------------------------------------- /test/unit/test_string.lml: -------------------------------------------------------------------------------- 1 | 2 | module Test = struct 3 | 4 | val main: unit -> unit 5 | let main() = 6 | let s = "This is a test" in 7 | let s2 = ", this is the \t rest of the test\n" in 8 | let s = String.make s in 9 | let s2 = String.make s2 in 10 | let s = String.append s s2 in 11 | Print.int (String.length !s) ; 12 | Print.rstring !s ; 13 | String.release s 14 | end 15 | -------------------------------------------------------------------------------- /test/unit/test_typing.lml: -------------------------------------------------------------------------------- 1 | module List = struct 2 | type 'a t = 3 | | Empty 4 | | Cons of 'a * 'a t 5 | (* 6 | val rev_append: 'a t * 'a t -> 'a t 7 | let rev_append acc l = 8 | match l with 9 | | [] -> acc 10 | | x :: rl -> rev_append (x :: acc) rl 11 | 12 | val rev: 'c t -> 'c t 13 | let rev l = rev_append [] l 14 | 15 | val append: 'b t * 'b t -> 'b t 16 | let append l1 l2 = 17 | match l1 with 18 | | [] -> l2 19 | | x :: rl -> x :: append rl l2 20 | *) 21 | (* 22 | val map: ('c -> 'b) * 'c t -> 'b t 23 | let map f l = 24 | match l with 25 | | [] -> [] 26 | | x :: rl -> 27 | let x = f x in 28 | let rl = map f rl in 29 | x :: rl 30 | *) 31 | 32 | (* 33 | val bb: 'a t * 'a t -> 'a t 34 | let bb l1 l2 = 35 | let l1 = Cons 1 l1 in 36 | l1 37 | *) 38 | 39 | (* 40 | val init_: int * 'a * ('a * int #-> 'b) #-> 'b t = "liml_array_make" 41 | 42 | val call_int: ('c -> 'd) * 'c #-> 'd = asm "" 43 | 44 | val init: int * (int -> 'e) -> 'e t 45 | let init n f = init_ n f call_int 46 | *) 47 | 48 | (* 49 | val init_: int * ('a * int #-> 'b) * 'a #-> 'b t = "liml_array_make" 50 | 51 | val call_int: ('c -> 'd) * 'c #-> 'd = asm "" 52 | 53 | val init: int * (int -> 'e) -> 'e t 54 | let init n f = init_ n call_int f 55 | *) 56 | 57 | (* 58 | val test: ('a #-> 'a) #-> bool 59 | let test f = 60 | let x = f true in 61 | let y = f "hhelo" in 62 | x 63 | *) 64 | 65 | (* 66 | val test: ('a #-> 'a) #-> unit = "dd" 67 | val b: (int #-> int) #-> unit 68 | let b f = test f 69 | *) 70 | 71 | (* 72 | val test: ('c * 'c #-> 'c) #-> unit = "dd" 73 | val b: ('a * 'a #-> 'a) #-> unit 74 | let b f = test f 75 | *) 76 | 77 | (* 78 | val test: 'a -> 'a = asm "dd" 79 | val b: int -> int = asm "bb" 80 | val f: unit -> (int -> int) 81 | let f () = 82 | let x = if true then b else test in 83 | x 84 | *) 85 | 86 | (* 87 | val test: 'a -> 'a = asm "dd" 88 | val b: 'b -> 'b = asm "bb" 89 | val f: unit -> ('c -> 'c) 90 | let f () = 91 | let x = if true then b else test in 92 | x 93 | *) 94 | 95 | (* 96 | val test: (int #-> int) #-> 'd = "test" 97 | val b: ('a #-> 'a) #-> unit 98 | let b f = 99 | let x = test f in 100 | x 101 | *) 102 | 103 | (* 104 | val test: ('a -> 'b -> 'b) -> 'd = asm "test" 105 | val b: ('a -> 'c -> 'd) -> _ 106 | let b f = test f 107 | *) 108 | 109 | (* 110 | val test: (('a -> 'b) -> 'b) * 'a -> 'd = asm "test" 111 | val b: (('a -> 'a) -> 'a) * 'a -> _ 112 | let b f x = test f x 113 | *) 114 | 115 | (* 116 | val test: ('a -> 'b -> 'c) -> 'd = asm "test" 117 | val b: ('a -> 'b -> 'b) -> _ 118 | let b f = test f 119 | *) 120 | 121 | (* 122 | val app: ('a -> 'b) * 'a -> 'b = asm "" 123 | val b: ('c -> 'd) * 'c -> 'd 124 | let b f x = 125 | let y = app f x in 126 | y 127 | *) 128 | (* 129 | val g: 'a -> 'a = asm "" 130 | val f: 'b -> 'b 131 | let f x = 132 | let y = g g in 133 | x 134 | *) 135 | (* 136 | val f: 'a -> 'a -> 'b = asm "" 137 | 138 | val g: unit -> unit 139 | let g () = 140 | let h = f 1 in 141 | let _ = h () in 142 | let _ = h "true" in 143 | () 144 | *) 145 | end 146 | 147 | 148 | --------------------------------------------------------------------------------