From b74819d104f9a87f3e245ff9c9cafaf255d99f2e Mon Sep 17 00:00:00 2001 From: "A. Hacker" Date: Fri, 28 Jan 2011 19:08:22 -0800 Subject: [PATCH] added "asm" capability one can define "inlined assembly" using the following syntax val my_fun: signature = asm "llvm_function" --- ast.ml | 10 +++++++- emit.ml | 9 ++++--- estPp.ml | 3 +++ ist.ml | 2 +- istOfStast.ml | 2 +- lexer.mll | 4 ++++ llst.ml | 2 +- llstPp.ml | 8 +++++-- naming.ml | 2 +- nast.ml | 2 +- neast.ml | 2 +- neastCheck.ml | 6 ++--- parser.mly | 14 +++++++++-- stast.ml | 2 +- stdlib/array.c | 39 ------------------------------ stdlib/array.lml | 21 ---------------- stdlib/farray.as | 18 ++++++++++++++ stdlib/farray.c | 18 ++++++++++++++ stdlib/farray.lml | 48 +++++++++++++++++++++++++++++++++++++ stdlib/iarray.as | 18 ++++++++++++++ stdlib/iarray.c | 23 ++++++++++++++++++ stdlib/iarray.lml | 49 ++++++++++++++++++++++++++++++++++++++ test/shootout/Makefile | 40 +++++++++++++++++++------------ test/shootout/custom_lib.c | 2 ++ test/shootout/fankuch.lml | 33 ++++++++++--------------- test/shootout/spectral.lml | 36 ++++++++++++++-------------- test/unit/closure.lml | 25 +++++++++++++++++++ typing.ml | 14 ++++++++--- 28 files changed, 317 insertions(+), 135 deletions(-) create mode 100644 stdlib/farray.as create mode 100644 stdlib/farray.c create mode 100644 stdlib/farray.lml create mode 100644 stdlib/iarray.as create mode 100644 stdlib/iarray.c create mode 100644 stdlib/iarray.lml create mode 100644 test/unit/closure.lml diff --git a/ast.ml b/ast.ml index 3f54440..6fe27d7 100644 --- a/ast.ml +++ b/ast.ml @@ -33,7 +33,12 @@ and def = | Dmodule of id * id | Dlet of id * pat list * expr | Dtype of (id * type_expr) list - | Dval of id * type_expr * pstring option + | Dval of id * type_expr * extern_def + +and extern_def = + | Ext_none + | Ext_C of pstring (* C function *) + | Ext_Asm of pstring (* Assembly function *) and pat = Pos.t * pat_ and pat_ = @@ -101,6 +106,9 @@ and bop = | Eminus | Estar | Ediv + | Eor + | Eand and uop = | Euminus + | Enot diff --git a/emit.ml b/emit.ml index 5d4022a..af980c5 100644 --- a/emit.ml +++ b/emit.ml @@ -9,6 +9,7 @@ let make_cconv = function | Ast.Cfun -> Llvm.CallConv.c | Ast.Lfun -> Llvm.CallConv.fast + module MakeNames = struct let rec program mdl = @@ -18,7 +19,7 @@ module MakeNames = struct List.iter (decl md.md_id) md.md_decls and decl md = function - | Dval (x, _, Some y) -> + | Dval (x, _, (Ast.Ext_C (_, y) | Ast.Ext_Asm (_, y))) -> Ident.set_name x y | Dtype (x, _) | Dval (x, _, _) -> @@ -74,7 +75,7 @@ module Type = struct IMap.add df.df_id fun_ acc and def_external mds t md ctx acc = function - | Dval (x, Tfun (_, ty1, ty2), Some v) -> + | Dval (x, Tfun (_, ty1, ty2), (Ast.Ext_C (_, v) | Ast.Ext_Asm (_, v))) -> let ty = type_fun mds t ctx ty1 ty2 in let fdec = declare_function v ty md in IMap.add x fdec acc @@ -425,7 +426,7 @@ and extract_values env acc xl v = IMap.add x nv acc ) acc xl -and expr bb env acc (ty, x) e = +and expr bb env acc (ty, x) e = let xs = Ident.to_string x in match e with | Efree _ -> assert false @@ -584,6 +585,8 @@ and binop ty = function | Tint -> build_sdiv | Tfloat -> build_fdiv | _ -> assert false) + | Eand -> build_and + | Eor -> build_or and const env ty = function | Eunit -> assert false diff --git a/estPp.ml b/estPp.ml index 0a98f96..e349d12 100644 --- a/estPp.ml +++ b/estPp.ml @@ -173,6 +173,9 @@ and binop = function | Ast.Eminus -> o "minus" | Ast.Estar -> o "star" | Ast.Ediv -> o "div" + | Ast.Eand -> o "and" + | Ast.Eor -> o "or" and unop = function | Ast.Euminus -> o "uminus" + | Ast.Enot -> o "not" diff --git a/ist.ml b/ist.ml index d79047f..b023d2d 100644 --- a/ist.ml +++ b/ist.ml @@ -14,7 +14,7 @@ and module_ = { and decl = | Dalgebric of tdef | Drecord of tdef - | Dval of id * type_expr * pstring option + | Dval of id * type_expr * Ast.extern_def and tdef = { td_id: id ; diff --git a/istOfStast.ml b/istOfStast.ml index 8f398b3..950b436 100644 --- a/istOfStast.ml +++ b/istOfStast.ml @@ -16,7 +16,7 @@ and module_ md = { and decl = function | Dalgebric x -> Ist.Dalgebric (tdef x) | Drecord x -> Ist.Drecord (tdef x) - | Dval (x, y, v) -> Ist.Dval (id x, type_expr y, opt pstring v) + | Dval (x, y, v) -> Ist.Dval (id x, type_expr y, v) and tdef td = { Ist.td_id = id td.td_id ; diff --git a/lexer.mll b/lexer.mll index 9045135..3840cca 100644 --- a/lexer.mll +++ b/lexer.mll @@ -36,6 +36,8 @@ let assoc_keyword = [ "to" , (fun lb -> TO (Pos.make lb)) ; "begin" , (fun lb -> BEGIN (Pos.make lb)) ; "in" , (fun lb -> IN (Pos.make lb)) ; + "not" , (fun lb -> NOT (Pos.make lb)) ; + "asm" , (fun lb -> ASM (Pos.make lb)) ; ] let _ = @@ -96,6 +98,8 @@ rule token = parse | '=' { EQ (Pos.make lexbuf) } | "<>" { DIFF (Pos.make lexbuf) } | "==" { EQEQ (Pos.make lexbuf) } + | "||" { BARBAR (Pos.make lexbuf) } + | "&&" { AMPAMP (Pos.make lexbuf) } | '+' { PLUS (Pos.make lexbuf) } | '-' { MINUS (Pos.make lexbuf)} | '*' { STAR (Pos.make lexbuf) } diff --git a/llst.ml b/llst.ml index c5e72b7..fd62adb 100644 --- a/llst.ml +++ b/llst.ml @@ -14,7 +14,7 @@ and module_ = { and decl = | Dtype of id * type_expr - | Dval of id * type_expr * pstring option + | Dval of id * type_expr * Ast.extern_def and type_expr = | Tany diff --git a/llstPp.ml b/llstPp.ml index 236a353..a154777 100644 --- a/llstPp.ml +++ b/llstPp.ml @@ -46,8 +46,9 @@ and decl = function | Dval (x, ty, v) -> o "val " ; id x ; o ": " ; type_expr ty ; (match v with - | None -> () - | Some x -> o " = " ; o x) ; + | Ast.Ext_none -> () + | Ast.Ext_C x -> o " = " ; o (snd x) + | Ast.Ext_Asm x -> o " = (asm)" ; o (snd x)) ; nl () ; and type_expr = function @@ -177,6 +178,9 @@ and binop = function | Ast.Eminus -> o "minus" | Ast.Estar -> o "star" | Ast.Ediv -> o "div" + | Ast.Eor -> o "or" + | Ast.Eand -> o "and" and unop = function | Ast.Euminus -> o "uminus" + | Ast.Enot -> o "not" diff --git a/naming.ml b/naming.ml index 8aedba6..979707d 100644 --- a/naming.ml +++ b/naming.ml @@ -327,7 +327,7 @@ and dtype genv sig_ env tdl = env, (List.map (type_def genv sig_ env) tdl) and external_ sig_ env = function - | Dval (x, _, Some _) -> Env.add_value env x (Env.value sig_ x) + | Dval (x, _, (Ext_C _ | Ext_Asm _)) -> Env.add_value env x (Env.value sig_ x) | _ -> env and bind_type sig_ env (x, _) = diff --git a/nast.ml b/nast.ml index 001b951..a8b7a09 100644 --- a/nast.ml +++ b/nast.ml @@ -13,7 +13,7 @@ and module_ = { and decl = | Dtype of (id * type_expr) list - | Dval of id * type_expr * pstring option + | Dval of id * type_expr * Ast.extern_def and type_expr = Pos.t * type_expr_ and type_expr_ = diff --git a/neast.ml b/neast.ml index b8e2220..865e045 100644 --- a/neast.ml +++ b/neast.ml @@ -15,7 +15,7 @@ and decl = | Dalgebric of tdef | Drecord of tdef | Dabstract of id * id list - | Dval of id * type_expr * pstring option + | Dval of id * type_expr * Ast.extern_def and tdef = { td_id: id ; diff --git a/neastCheck.ml b/neastCheck.ml index 11d30fd..e130782 100644 --- a/neastCheck.ml +++ b/neastCheck.ml @@ -199,7 +199,7 @@ module CheckExternal = struct List.iter decl md.md_decls and decl = function - | Dval (_, ty, Some _) -> + | Dval (_, ty, Ast.Ext_C _) -> (try type_expr ty with Error p -> Error.invalid_extern_type (fst ty) p) @@ -254,8 +254,8 @@ module CheckSig = struct | _ -> acc and extern exts x = function - | None -> exts - | Some v -> IMap.add (snd x) (fst v) exts + | Ast.Ext_none -> exts + | Ast.Ext_C v | Ast.Ext_Asm v -> IMap.add (snd x) (fst v) exts and def acc (x, _, _) = let lets = IMap.add (snd x) (fst x) acc.lets in diff --git a/parser.mly b/parser.mly index 2a0a25a..8f9883c 100644 --- a/parser.mly +++ b/parser.mly @@ -43,12 +43,14 @@ let dtype l = (List.map (fun ((x, idl), ty) -> %} +%token AMPAMP %token AND %token ARROW %token SARROW %token AS %token ASSIGN %token BAR +%token BARBAR %token BEGIN %token CHAR %token COLEQ @@ -73,6 +75,7 @@ let dtype l = (List.map (fun ((x, idl), ty) -> %token IF %token IN %token INT +%token ASM %token FLOAT %token LET %token LB @@ -83,6 +86,7 @@ let dtype l = (List.map (fun ((x, idl), ty) -> %token MATCH %token MINUS %token MODULE +%token NOT %token OF %token RB %token RCB @@ -116,10 +120,12 @@ let dtype l = (List.map (fun ((x, idl), ty) -> %right SC %nonassoc if_ %right COMMA +%left BARBAR AMPAMP %left EQ DIFF LT LTE GT GTE %right COLONCOLON %left PLUS MINUS %left STAR SLASH +%nonassoc NOT %left apply_ DOT %nonassoc module_dot %left unary_minus @@ -159,8 +165,9 @@ rec_opt: | REC { } external_opt: -| { None } -| EQ STRING { Some $2 } +| { Ext_none } +| EQ STRING { Ext_C $2 } +| EQ ASM STRING { Ext_Asm $3 } type_decl: | type_id { $1, (Pos.none, Tabstract) } @@ -351,6 +358,9 @@ expr: | expr MINUS expr { btw $1 $3, Ebinop (Eminus, $1, $3) } | expr STAR expr { btw $1 $3, Ebinop (Estar, $1, $3) } | expr SLASH expr { btw $1 $3, Ebinop (Ediv, $1, $3) } +| expr BARBAR expr { btw $1 $3, Ebinop (Eor, $1, $3) } +| expr AMPAMP expr { btw $1 $3, Ebinop (Eand, $1, $3) } +| NOT expr { Pos.btw $1 (fst $2), Euop (Enot, $2) } | expr SC expr { btw $1 $3, Eseq ($1, $3) } | expr COMMA expr { btw $1 $3, Etuple [$1;$3] } | ID COLEQ expr SC expr { btw $1 $5, Elet ((fst $1, Pid $1), $3, $5) } diff --git a/stast.ml b/stast.ml index e9e4dd2..48dd02f 100644 --- a/stast.ml +++ b/stast.ml @@ -14,7 +14,7 @@ and module_ = { and decl = | Dalgebric of tdef | Drecord of tdef - | Dval of id * type_expr * pstring option + | Dval of id * type_expr * Ast.extern_def and tdef = { td_id: id ; diff --git a/stdlib/array.c b/stdlib/array.c index 056f374..cd80803 100644 --- a/stdlib/array.c +++ b/stdlib/array.c @@ -59,45 +59,6 @@ void* array_get(array_t* t, int n){ return t->t[n] ; } -typedef struct{ - int size ; - double* t ; -} farray_t ; - -farray_t* farray_make(int size, double d){ - farray_t* res ; - int i ; - res = malloc(sizeof(farray_t)) ; - res->size = size ; - res->t = malloc(sizeof(double) * size) ; - for (i = 0 ; i < size ; i++){ - res->t[i] = d ; - } - return res ; -} - -farray_t* farray_set(farray_t* t, int i, double v){ - if(i < 0 || i >= t->size) - return t ; - t->t[i] = v ; - return t ; -} - -double farray_get(farray_t* t, int i){ - if(i < 0 || i >= t->size) - return 0.0 ; - return t->t[i] ; -} - -void farray_release(farray_t* t){ - free(t->t) ; - free(t) ; - return ; -} - -int farray_length(farray_t* t){ - return t->size ; -} typedef struct{ int size ; diff --git a/stdlib/array.lml b/stdlib/array.lml index 89c399a..f3ac8cd 100644 --- a/stdlib/array.lml +++ b/stdlib/array.lml @@ -19,24 +19,3 @@ module Array = struct val length: 'a t obs #-> int = "array_length" end -module FloatArray = struct - type t - val make: int * float #-> t = "farray_make" - val set: t * int * float #-> t = "farray_set" - val get: t obs * int #-> float = "farray_get" - val length: t obs #-> int = "farray_length" - val release: t #-> unit = "farray_release" -end - -module IntArray = struct - type t - val make: int * int #-> t = "iarray_make" - val set: t * int * int #-> t = "iarray_set" - val get: t obs * int #-> int = "iarray_get" - val length: t obs #-> int = "iarray_length" - val copy: t obs #-> t = "iarray_copy" - val copy_to: t obs * t #-> t = "iarray_copy_to" - val release: t #-> unit = "iarray_release" - val iteri: (t * int * int #-> t) * t #-> t = "iarray_mapti" - -end diff --git a/stdlib/farray.as b/stdlib/farray.as new file mode 100644 index 0000000..75f7b48 --- /dev/null +++ b/stdlib/farray.as @@ -0,0 +1,18 @@ + +; ModuleID = 'FA' + +define fastcc double @unsafe_farray_get(i8* %t, i32 %i) alwaysinline{ +entry: + %td = bitcast i8* %t to double* ; + %tmp = getelementptr double* %td, i32 %i ; + %res = load double* %tmp ; + ret double %res ; +} + +define fastcc i8* @unsafe_farray_set(i8* %t, i32 %i, double %x) alwaysinline{ +entry: + %td = bitcast i8* %t to double* ; + %tmp = getelementptr double* %td, i32 %i ; + store double %x, double* %tmp ; + ret i8* %t ; +} diff --git a/stdlib/farray.c b/stdlib/farray.c new file mode 100644 index 0000000..1250bb4 --- /dev/null +++ b/stdlib/farray.c @@ -0,0 +1,18 @@ +#include + +double* unsafe_farray_make(int n, double d){ + double* res = malloc(sizeof(double) * n) ; + int i ; + + for (i = 0 ; i < n ; i++){ + res[i] = d ; + } + + return res ; +} + +void unsafe_farray_release(double* d){ + free(d) ; + return ; +} + diff --git a/stdlib/farray.lml b/stdlib/farray.lml new file mode 100644 index 0000000..b8de233 --- /dev/null +++ b/stdlib/farray.lml @@ -0,0 +1,48 @@ + +module UnsafeFloatArray = struct + type t + + val make: int * float #-> t = "unsafe_farray_make" + val release: t #-> unit = "unsafe_farray_release" + val set: t * int * float -> t = asm "unsafe_farray_set" + val get: t obs * int -> float = asm "unsafe_farray_get" + +end + +module FloatArray = struct + + type t = { + size: int ; + v: UnsafeFloatArray.t ; + } + + val make: int * float -> t + let make n d = + { size = n ; + v = UnsafeFloatArray.make n d } + + val set: t * int * float #-> t + let set t x f = + if x < 0 || x >= t.size + then t + else + let { t ; ~v } = t in + let v = UnsafeFloatArray.set v x f in + { t with ~v } + + val get: t obs * int -> float + let get t x = + if x < 0 || x >= t.size + then 0.0 + else UnsafeFloatArray.get t.v x + + val length: t obs -> int + let length t = t.size + + val release: t -> unit + let release t = + let { t ; ~v } = t in + UnsafeFloatArray.release v ; + free t + +end diff --git a/stdlib/iarray.as b/stdlib/iarray.as new file mode 100644 index 0000000..28a7730 --- /dev/null +++ b/stdlib/iarray.as @@ -0,0 +1,18 @@ + +; ModuleID = 'FA' + +define fastcc i32 @unsafe_iarray_get(i8* %t, i32 %i) alwaysinline{ +entry: + %td = bitcast i8* %t to i32* ; + %tmp = getelementptr i32* %td, i32 %i ; + %res = load i32* %tmp ; + ret i32 %res ; +} + +define fastcc i8* @unsafe_iarray_set(i8* %t, i32 %i, i32 %x) alwaysinline{ +entry: + %td = bitcast i8* %t to i32* ; + %tmp = getelementptr i32* %td, i32 %i ; + store i32 %x, i32* %tmp ; + ret i8* %t ; +} diff --git a/stdlib/iarray.c b/stdlib/iarray.c new file mode 100644 index 0000000..db4f2b6 --- /dev/null +++ b/stdlib/iarray.c @@ -0,0 +1,23 @@ +#include +#include + +int* unsafe_iarray_make(int n, int d){ + int* res = malloc(sizeof(int) * n) ; + int i ; + + for (i = 0 ; i < n ; i++){ + res[i] = d ; + } + + return res ; +} + +void unsafe_iarray_release(int* d){ + free(d) ; + return ; +} + +void* unsafe_iarray_copy(void* src, void* dest, int n){ + memcpy(dest, src, n * sizeof(int)) ; + return dest ; +} diff --git a/stdlib/iarray.lml b/stdlib/iarray.lml new file mode 100644 index 0000000..bc1ecef --- /dev/null +++ b/stdlib/iarray.lml @@ -0,0 +1,49 @@ + +module UnsafeIntArray = struct + type t + + val make: int * int #-> t = "unsafe_iarray_make" + val release: t #-> unit = "unsafe_iarray_release" + val set: t * int * int -> t = asm "unsafe_iarray_set" + val get: t obs * int -> int = asm "unsafe_iarray_get" + val copy: t obs * t * int #-> t = "unsafe_iarray_copy" + +end + +module IntArray = struct + + type t = { + size: int ; + v: UnsafeIntArray.t ; + } + + val make: int * int -> t + let make n d = + { size = n ; + v = UnsafeIntArray.make n d } + + val set: t * int * int #-> t + let set t x f = + if x < 0 || x >= t.size + then t + else + let { t ; ~v } = t in + let v = UnsafeIntArray.set v x f in + { t with ~v } + + val get: t obs * int -> int + let get t x = + if x < 0 || x >= t.size + then 0 + else UnsafeIntArray.get t.v x + + val length: t obs -> int + let length t = t.size + + val release: t -> unit + let release t = + let { t ; ~v } = t in + UnsafeIntArray.release v ; + free t + +end diff --git a/test/shootout/Makefile b/test/shootout/Makefile index c7d954c..ebd0f3f 100644 --- a/test/shootout/Makefile +++ b/test/shootout/Makefile @@ -1,6 +1,8 @@ LIMLC = ../../limlc -LLC = llc -tailcallopt +LLC = llc -tailcallopt -O3 +LINK = llvm-link +OPT = opt CC = gcc -O3 # llvm_executionengine.cma @@ -8,46 +10,54 @@ CC = gcc -O3 LIML_LIBS = ../../stdlib/*.lml CC_LIBS = -lpthread -lm -default: fankuch +default: fankuch bintree spectral FILES_LIML = \ bintree.lml -MODULES_LIML = \ +BC_FILES = \ + ../../stdlib/iarray.bc \ + ../../stdlib/farray.bc \ Print.bc\ List.bc \ + FloatArray.bc \ IntBox.bc \ Future.bc \ BinaryTree.bc \ SpectralNorm.bc \ - Fankuch.bc + Fankuch.bc STDLIB_OBJS = ../../stdlib/*.o -FILES_ASM = $(MODULES_LIML:.bc=.s) .PHONY: objects objects: $(FILES_LIML) $(LIMLC) $(LIML_LIBS) *.lml -bintree: objects $(FILES_ASM) custom_lib.o bintree_main.o - $(CC) $(FILES_ASM) $(STDLIB_OBJS) custom_lib.o bintree_main.o $(CC_LIBS) -o $@ +bintree: objects $(BC_FILES) custom_lib.o bintree_main.o + $(LINK) $(BC_FILES) -o bintree.bc + $(OPT) -std-link-opts bintree.bc -o bintree_opt.bc + $(LLC) bintree_opt.bc + $(CC) bintree_opt.s $(STDLIB_OBJS) custom_lib.o bintree_main.o $(CC_LIBS) -o $@ -spectral: objects $(FILES_ASM) custom_lib.o spectral_main.o - $(CC) $(FILES_ASM) $(STDLIB_OBJS) custom_lib.o spectral_main.o $(CC_LIBS) -o $@ +spectral: objects $(BC_FILES) custom_lib.o spectral_main.o + $(LINK) ../../stdlib/farray.bc Print.bc FloatArray.bc SpectralNorm.bc -o spectral.bc + $(OPT) -std-link-opts spectral.bc -o spectral_opt.bc + $(LLC) spectral_opt.bc + $(CC) spectral_opt.s $(STDLIB_OBJS) custom_lib.o spectral_main.o $(CC_LIBS) -o $@ -fankuch: objects $(FILES_ASM) custom_lib.o fankuch_main.o - $(CC) $(FILES_ASM) $(STDLIB_OBJS) custom_lib.o fankuch_main.o $(CC_LIBS) -o $@ +fankuch: objects $(BC_FILES) custom_lib.o fankuch_main.o + $(LINK) ../../stdlib/iarray.bc IntArray.bc Fankuch.bc Print.bc -o fankuch.bc + $(OPT) -std-link-opts fankuch.bc -o fankuch_opt.bc + $(LLC) fankuch_opt.bc + $(CC) fankuch_opt.s $(STDLIB_OBJS) custom_lib.o fankuch_main.o $(CC_LIBS) -pg -o $@ -%.s : %.bc - $(LLC) $< - %.o : %.c $(CC) -c $< clean: - rm -f ./bintree ./spectral + rm -f ./bintree ./spectral ./fankuch rm -f *.o *.s *.bc *~ test/*.o test/*.s diff --git a/test/shootout/custom_lib.c b/test/shootout/custom_lib.c index d7415d7..7fead81 100644 --- a/test/shootout/custom_lib.c +++ b/test/shootout/custom_lib.c @@ -3,3 +3,5 @@ double float_of_int(int x){ return (double)x ; } int lsl(int x, int y){ return (x << y) ; } int land(int x, int y) { return (x & y) ; } void debug(void* p) { printf("%p\n", p) ; } +void* magic(void* p) { return p; } +void magic2(void* p) { return ; } diff --git a/test/shootout/fankuch.lml b/test/shootout/fankuch.lml index 90a93bb..9df65d3 100644 --- a/test/shootout/fankuch.lml +++ b/test/shootout/fankuch.lml @@ -1,18 +1,15 @@ module Fankuch = struct - module IA = IntArray + module IA = UnsafeIntArray val land: int * int #-> int = "land" val lsl: int * int #-> int = "lsl" val debug: IA.t obs #-> unit = "debug" (** Flip the front [n] pancakes of [a]. *) - val flip: int * IA.t -> IA.t - let flip n a = flip_loop n a 0 (n/2) - - val flip_loop: int * IA.t * int * int -> IA.t - let flip_loop n a i iend = + val flip: int * IA.t * int * int -> IA.t + let flip n a i iend= if i > iend then a else begin @@ -21,19 +18,19 @@ module Fankuch = struct let ak = (IA.get (obs a) k) in a := IA.set a i ak ; a := IA.set a k t ; - flip_loop n a (i+1) iend + flip n a (i+1) iend end (** Count the number of flips so that pancake 0 is at index 0. *) val count: int * IA.t -> int * IA.t let count c ary = let z = IA.get (obs ary) 0 in - if z <> 0 then begin - let ary = flip z ary in + if z = 0 then c, ary + else begin + let ary = flip z ary 0 (z/2) in let c = c + 1 in count c ary - end else - c, ary + end (** Rotate the first [n] pancakes of [a]. *) val rotate: int * IA.t -> IA.t @@ -61,22 +58,16 @@ module Fankuch = struct copy: IA.t ; ht: int ; } - - val array_copy: IA.t obs * IA.t * int -> IA.t - let array_copy t1 t2 n = - if n < 0 - then t2 - else array_copy t1 (IA.set t2 n (IA.get t1 n)) (n-1) val do_iter: env -> env let do_iter env = if env.ht = 1 then begin let { env ; ~copy } = env in - let copy = array_copy env.perm copy (IA.length env.perm) in + let copy = IA.copy env.perm copy env.n in let c, copy = count 0 copy in let csum = env.csum + c * (1 - (lsl (land env.num 1) 1)) in let m = if c > env.m then c else env.m in - let env = { env with csum = csum ; m = m ; num = env.num + 1 ; ~copy } in + let env = { env with ~csum ; ~m ; num = env.num + 1 ; ~copy } in env end else do_iter_loop env 1 @@ -101,7 +92,7 @@ module Fankuch = struct val iter_perms: int -> env let iter_perms n = let perm = IA.make n 0 in - let perm = init_perm perm n in + let perm = init_perm perm (n-1) in let copy = IA.make n 0 in let csum = 0 in let m = 0 in @@ -118,7 +109,7 @@ module Fankuch = struct val main: unit #-> unit let main () = - let n = 9 in + let n = 10 in let env = iter_perms n in Print.int env.csum ; Print.newline() ; diff --git a/test/shootout/spectral.lml b/test/shootout/spectral.lml index f91d392..9316faf 100644 --- a/test/shootout/spectral.lml +++ b/test/shootout/spectral.lml @@ -1,16 +1,16 @@ module SpectralNorm = struct - module FA = FloatArray + module FA = UnsafeFloatArray val float_of_int: int #-> float = "float_of_int" val eval_A: int * int -> float let eval_A i j = 1.0 / float_of_int ((i+j)*(i+j+1)/2+i+1) - val eval_A_times_u: FA.t obs * FA.t -> FA.t - let eval_A_times_u u v = - let n = FA.length (obs v) - 1 in + val eval_A_times_u: int * FA.t obs * FA.t -> FA.t + let eval_A_times_u n u v = + let n = n - 1 in eval_A_times_u_loop u v 0 n val eval_A_times_u_loop: FA.t obs * FA.t * int * int -> FA.t @@ -31,9 +31,9 @@ module SpectralNorm = struct let vi = vi + eval_A i j * uj in eval_A_times_u_loop2 u v i (j+1) n vi - val eval_At_times_u: FA.t obs * FA.t -> FA.t - let eval_At_times_u u v = - let n = FA.length (obs v) - 1 in + val eval_At_times_u: int * FA.t obs * FA.t -> FA.t + let eval_At_times_u n u v = + let n = n - 1 in eval_At_times_u_loop u v 0 n val eval_At_times_u_loop: FA.t obs * FA.t * int * int -> FA.t @@ -55,22 +55,22 @@ module SpectralNorm = struct eval_At_times_u_loop2 u v i (j+1) n vi - val eval_AtA_times_u: FA.t obs * FA.t -> FA.t - let eval_AtA_times_u u v = - let w = FA.make (FA.length u) 0.0 in - let w = eval_A_times_u u w in - let v = eval_At_times_u (obs w) v in + val eval_AtA_times_u: int * FA.t obs * FA.t -> FA.t + let eval_AtA_times_u n u v = + let w = FA.make n 0.0 in + let w = eval_A_times_u n u w in + let v = eval_At_times_u n (obs w) v in FA.release w ; v - val main_loop1: FA.t * FA.t * int -> FA.t * FA.t - let main_loop1 u v i = + val main_loop1: int * FA.t * FA.t * int -> FA.t * FA.t + let main_loop1 n u v i = if i > 9 then u, v else - let v = eval_AtA_times_u (obs u) v in - let u = eval_AtA_times_u (obs v) u in - main_loop1 u v (i+1) + let v = eval_AtA_times_u n (obs u) v in + let u = eval_AtA_times_u n (obs v) u in + main_loop1 n u v (i+1) val main_loop2: FA.t obs * FA.t obs * int * int * float * float -> float * float let main_loop2 u v n i vv vBv = @@ -87,7 +87,7 @@ module SpectralNorm = struct let n = 2000 in let u = FA.make n 1.0 in let v = FA.make n 0.0 in - let u, v = main_loop1 u v 0 in + let u, v = main_loop1 n u v 0 in let vv, vBv = main_loop2 (obs u) (obs v) n 0 0.0 0.0 in FA.release u ; FA.release v ; diff --git a/test/unit/closure.lml b/test/unit/closure.lml new file mode 100644 index 0000000..ce3b8ac --- /dev/null +++ b/test/unit/closure.lml @@ -0,0 +1,25 @@ + +module UnitTestClosure = struct + + type env = { + x: int + } + + val free_env: env #-> unit + let free_env env = free env + + val f: (env, IntBox.t) Couple.t #-> (env, IntBox.t) Couple.t + let f cpl = + let env, y = Couple.break cpl in + let y = env.x + IntBox.unbox y in + let env = { env with x = y } in + Couple.make env (IntBox.make y) + + val main: unit #-> unit + let main x = + let env = { x = 0 } in + let cls = Closure.make f free_env env in + let cls, v = Closure.call cls (IntBox.make 1) in + Closure.release cls ; + Print.int (IntBox.unbox v) +end diff --git a/typing.ml b/typing.ml index 76d3d1c..2800a06 100644 --- a/typing.ml +++ b/typing.ml @@ -349,8 +349,8 @@ with Error.Type errl -> Error.unify errl and declare env = function - | Dval (x, ty, Some _) -> IMap.add (snd x) ty env - | Dval (x, ty, None) -> IMap.add (snd x) ty env + | Dval (x, ty, (Ast.Ext_C _ | Ast.Ext_Asm _)) -> IMap.add (snd x) ty env + | Dval (x, ty, Ast.Ext_none) -> IMap.add (snd x) ty env | _ -> env and def env (fid, p, e) = @@ -553,15 +553,22 @@ and expr_ env (p, e) = (match bop with | Ast.Eplus | Ast.Eminus - | Ast.Estar -> + | Ast.Estar + | Ast.Ediv -> check_numeric p ty1 ; check_numeric p ty2 + | Ast.Eor | Ast.Eand -> (* TODO check bool *) () | _ -> ()) ; let _ = Unify.unify_el env ty1 ty2 in let ty = binop env bop p ty1 ty2 in (ty, Tast.Ebinop (bop, e1, e2)) + | Euop (Ast.Enot, e) -> + let (ty, _ as e) = expr env e in + (* TODO check bool *) + (ty, Tast.Euop (Ast.Euminus, e)) | Euop (Ast.Euminus, e) -> let (ty, _ as e) = expr env e in + (* TODO check numeric *) (ty, Tast.Euop (Ast.Euminus, e)) | Erecord fdl -> let fdl = List.map (variant env) fdl in @@ -634,6 +641,7 @@ and binop env bop p ty1 ty2 = | Ast.Eminus | Ast.Estar | Ast.Ediv -> Unify.unify_el env ty1 ty2 + | Ast.Eand | Ast.Eor -> (* TODO check bool ty1 ty2 *) (p, Tprim Tbool) and value = function | Nast.Eunit -> Tunit