Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

added "asm" capability

one can define "inlined assembly" using the following syntax
val my_fun: signature = asm "llvm_function"
  • Loading branch information...
commit b74819d104f9a87f3e245ff9c9cafaf255d99f2e 1 parent 996502b
A. Hacker authored
View
10 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
View
9 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
View
3  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"
View
2  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 ;
View
2  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 ;
View
4 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) }
View
2  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
View
8 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"
View
2  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, _) =
View
2  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_ =
View
2  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 ;
View
6 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
View
14 parser.mly
@@ -43,12 +43,14 @@ let dtype l = (List.map (fun ((x, idl), ty) ->
%}
+%token <Pos.t> AMPAMP
%token <Pos.t> AND
%token <Pos.t> ARROW
%token <Pos.t> SARROW
%token <Pos.t> AS
%token <Pos.t> ASSIGN
%token <Pos.t> BAR
+%token <Pos.t> BARBAR
%token <Pos.t> BEGIN
%token <Pos.t * string> CHAR
%token <Pos.t> COLEQ
@@ -73,6 +75,7 @@ let dtype l = (List.map (fun ((x, idl), ty) ->
%token <Pos.t> IF
%token <Pos.t> IN
%token <Pos.t * string> INT
+%token <Pos.t> ASM
%token <Pos.t * string> FLOAT
%token <Pos.t> LET
%token <Pos.t> LB
@@ -83,6 +86,7 @@ let dtype l = (List.map (fun ((x, idl), ty) ->
%token <Pos.t> MATCH
%token <Pos.t> MINUS
%token <Pos.t> MODULE
+%token <Pos.t> NOT
%token <Pos.t> OF
%token <Pos.t> RB
%token <Pos.t> 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) }
View
2  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 ;
View
39 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 ;
View
21 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
View
18 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 ;
+}
View
18 stdlib/farray.c
@@ -0,0 +1,18 @@
+#include<malloc.h>
+
+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 ;
+}
+
View
48 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
View
18 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 ;
+}
View
23 stdlib/iarray.c
@@ -0,0 +1,23 @@
+#include<malloc.h>
+#include<string.h>
+
+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 ;
+}
View
49 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
View
40 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
View
2  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 ; }
View
33 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() ;
View
36 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 ;
View
25 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
View
14 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
Please sign in to comment.
Something went wrong with that request. Please try again.