Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
added "asm" capability
one can define "inlined assembly" using the following syntax
val my_fun: signature = asm "llvm_function"
  • Loading branch information
A. Hacker committed Jan 29, 2011
1 parent 996502b commit b74819d
Show file tree
Hide file tree
Showing 28 changed files with 317 additions and 135 deletions.
10 changes: 9 additions & 1 deletion ast.ml
Expand Up @@ -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_ =
Expand Down Expand Up @@ -101,6 +106,9 @@ and bop =
| Eminus
| Estar
| Ediv
| Eor
| Eand

and uop =
| Euminus
| Enot
9 changes: 6 additions & 3 deletions emit.ml
Expand Up @@ -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 =
Expand All @@ -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, _, _) ->
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
3 changes: 3 additions & 0 deletions estPp.ml
Expand Up @@ -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"
2 changes: 1 addition & 1 deletion ist.ml
Expand Up @@ -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 ;
Expand Down
2 changes: 1 addition & 1 deletion istOfStast.ml
Expand Up @@ -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 ;
Expand Down
4 changes: 4 additions & 0 deletions lexer.mll
Expand Up @@ -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 _ =
Expand Down Expand Up @@ -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) }
Expand Down
2 changes: 1 addition & 1 deletion llst.ml
Expand Up @@ -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
Expand Down
8 changes: 6 additions & 2 deletions llstPp.ml
Expand Up @@ -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
Expand Down Expand Up @@ -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"
2 changes: 1 addition & 1 deletion naming.ml
Expand Up @@ -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, _) =
Expand Down
2 changes: 1 addition & 1 deletion nast.ml
Expand Up @@ -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_ =
Expand Down
2 changes: 1 addition & 1 deletion neast.ml
Expand Up @@ -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 ;
Expand Down
6 changes: 3 additions & 3 deletions neastCheck.ml
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
14 changes: 12 additions & 2 deletions parser.mly
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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) }
Expand Down Expand Up @@ -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) }
Expand Down
2 changes: 1 addition & 1 deletion stast.ml
Expand Up @@ -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 ;
Expand Down
39 changes: 0 additions & 39 deletions stdlib/array.c
Expand Up @@ -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 ;
Expand Down
21 changes: 0 additions & 21 deletions stdlib/array.lml
Expand Up @@ -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
18 changes: 18 additions & 0 deletions 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 ;
}
18 changes: 18 additions & 0 deletions 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 ;
}

0 comments on commit b74819d

Please sign in to comment.