disabled tuples in records for now + bug fixes

compiler/Makefile

@@ -38,6 +38,7 @@ OBJECTS_ML = \
 	ist.ml\
 	istPp.ml\
 	istOfStast.ml\
+	istTail.ml\
 	extractFuns.ml\
 	est.ml\
 	estSubst.ml\

compiler/emit.ml

@@ -153,8 +153,8 @@ module Type = struct
 
   and type_fun mds t ctx ty1 ty2 =
     let ty1, ty2 = 
-      if List.length ty2 > Global.max_reg_return
-      then Tptr (Tstruct ty2) :: ty1, [Tprim Tunit]
+      if List.length ty2 > 1
+      then Tptr (Tstruct ty2) :: ty1, []
       else ty1, ty2 in
     let ty1 = type_args mds t ctx ty1 in
     let rty = type_list mds t ctx ty2 in
@@ -202,7 +202,7 @@ module Type = struct
   and type_list mds t ctx l = 
     let tyl = List.map (type_ mds t ctx) l in
     match tyl with
-    | [] -> assert false
+    | [] -> void_type ctx
     | [x] -> x 
     | _ -> struct_type ctx (Array.of_list tyl)
 
@@ -240,6 +240,7 @@ module Pervasives = struct
     SMap.add name fdec interns
 *)
 
+(*
   let enot md ctx = 
     let builder = builder ctx in
     let int = Type.type_prim ctx Llst.Tint in
@@ -256,6 +257,7 @@ module Pervasives = struct
     let v = build_intcast v int "" builder in
     let _ = build_ret v builder in
     fdec
+*)
 
   let mk_trampoline = Ident.make "trampoline"
 
@@ -276,7 +278,7 @@ module Pervasives = struct
     let prims = IMap.add Naming.malloc malloc prims in
     let prims = IMap.add Naming.ifree free prims in
     let prims = IMap.add mk_trampoline trampoline prims in
-    let prims = IMap.add Naming.bnot (enot md ctx) prims in
+(*    let prims = IMap.add Naming.bnot (enot md ctx) prims in *)
     prims
 
 end
@@ -330,6 +332,10 @@ let dump_module md_file md pm =
 
 let optims pm = 
   ()
+    ;  add_memory_to_register_demotion pm
+    ;  add_tail_call_elimination pm
+(*    ;  add_instruction_combination pm  
+    ;  add_memory_to_register_promotion pm
     ;  add_constant_propagation pm
     ;  add_sccp pm
     ;  add_dead_store_elimination pm
@@ -341,7 +347,7 @@ let optims pm =
     ;  add_loop_unswitch pm
     ;  add_loop_unroll pm
     ;  add_loop_rotation pm
-    ;  add_memory_to_register_promotion pm 
+
     ;  add_reassociation pm
     ;  add_jump_threading pm
     ;  add_cfg_simplification pm
@@ -359,7 +365,7 @@ let optims pm =
     ;  add_scalar_repl_aggregation pm
     ;  add_ind_var_simplification pm  
     ; add_instruction_combination pm 
-
+*)
 
 let rec program base root no_opt dump_as mdl = 
   let ctx = global_context() in
@@ -419,7 +425,7 @@ and function_ env df =
   let params = Array.to_list params in
   let ret, params = 
     match params with
-    | ret :: params when List.length df.df_ret > Global.max_reg_return ->
+    | ret :: params when List.length df.df_ret > 1 ->
       Some ret, params 
     | _ -> None, params in
   env.ret := ret ;
@@ -506,7 +512,7 @@ and instructions bb env acc ret l =
   | [] -> return env acc ret ; acc
   | [vl1, Eapply (fk, _, f, l) as instr] ->
       (match ret with 
-      | Return (tail, vl2) when tail && fk = Ast.Lfun -> 
+      | Return (tail, vl2) when tail && fk = Ast.Lfun ->
 	  let t = build_args acc l in
 	  let f = find_function env acc (fst f) (snd f) in
 	  let v = build_call f (Array.of_list t) "" env.builder in
@@ -534,7 +540,7 @@ and instruction bb env acc (idl, e) =
   | [(_, x)], Efree (_, v) ->
       let f = IMap.find Naming.ifree env.prims in
       let v = IMap.find v acc in
-      let v = build_bitcast v (pointer_type (i8_type env.ctx)) "" env.builder in
+      let v = cast env (pointer_type (i8_type env.ctx)) v in
       let v = build_call f [|v|] "" env.builder in
       let cconv = Llvm.CallConv.c in
       set_instruction_call_conv cconv v ;
@@ -578,7 +584,7 @@ and apply env acc xl fk (fty, f) argl =
   let argl = build_args acc argl in
   let ret, argl = 
     match fty with
-    | Tfun (_, _, tyl) when List.length tyl > Global.max_reg_return ->
+    | Tfun (_, _, tyl) when List.length tyl > 1 ->
 	let int = Type.type_prim env.ctx Llst.Tint in
 	let tty = List.map (fun _ -> int) tyl in
 	let ty = struct_type env.ctx (Array.of_list tty) in
@@ -615,16 +621,16 @@ and extract_values env acc xl v =
     IMap.add x nv acc
  ) acc xl
 
-and cast env xs ty1 ty2 y = 
-  let ty1 = Type.type_ env.mds env.types env.ctx ty1 in
-  let ty2 = Type.type_ env.mds env.types env.ctx ty2 in
+and cast env ty v = 
+  let ty1 = ty in
+  let ty2 = type_of v in
   match classify_type ty1, classify_type ty2 with
-  | TypeKind.Pointer, TypeKind.Pointer -> build_bitcast y ty1 xs env.builder
-  | TypeKind.Pointer, _ -> build_inttoptr y ty1 "" env.builder
-  | _, TypeKind.Pointer -> build_ptrtoint y ty1 "" env.builder
+  | TypeKind.Pointer, TypeKind.Pointer -> build_bitcast v ty1 "" env.builder
+  | TypeKind.Pointer, _ -> build_inttoptr v ty1 "" env.builder
+  | _, TypeKind.Pointer -> build_ptrtoint v ty1 "" env.builder
   | TypeKind.Integer, TypeKind.Integer ->
-      build_intcast y ty1 xs env.builder
-  | _, _ -> build_bitcast y ty1 xs env.builder
+      build_intcast v ty1 "" env.builder
+  | _, _ -> build_bitcast v ty1 "" env.builder
 
 and expr bb env acc (ty, x) e =
   let xs = Ident.to_string x in
@@ -633,7 +639,8 @@ and expr bb env acc (ty, x) e =
   | Efree _ -> assert false
   | Eid (yty, y) -> 
       let y = try IMap.find y acc with Not_found -> find_function env acc ty y in
-      let v = cast env xs ty yty y in
+      let ty = Type.type_ env.mds env.types env.ctx ty in
+      let v = cast env ty y in
       IMap.add x v acc
   | Evalue v ->
       let ty = Type.type_ env.mds env.types env.ctx ty in
@@ -655,7 +662,7 @@ and expr bb env acc (ty, x) e =
       let v = bop x1 x2 xs env.builder in
       IMap.add x v acc
   | Eapply _ -> assert false
-  | Eis_null (_, v) -> 
+  | Eis_null (_, v) ->
       let v = IMap.find v acc in
       let v = build_is_null v xs env.builder in
       IMap.add x v acc
@@ -685,11 +692,23 @@ and expr bb env acc (ty, x) e =
       | Some (_, v) -> IMap.find v acc in
       let int = Type.type_prim env.ctx Llst.Tint in
       let z = const_int int 0 in
+      let tyl = 
+	match ty with 
+	| Tid x -> 
+	    (match IMap.find x env.orig_types with
+	    | Tstruct tyl -> tyl | _ -> assert false)
+	| _ -> assert false in
+      let n = ref 0 in
+      let types = Hashtbl.create 23 in
+      List.iter (fun ty -> Hashtbl.add types !n ty; incr n) tyl;
       List.iter (
       fun (n, (_, v)) -> 
+	let ty = Hashtbl.find types n in
 	let int = i32_type env.ctx in
 	let n = const_int int n in
 	let v = IMap.find v acc in
+	let ty = Type.type_ env.mds env.types env.ctx ty in
+	let v = cast env ty v in
 	let ptr = build_gep bl [|z;n|] "" env.builder in
 	ignore (build_store v ptr env.builder)
      ) fdl ;

compiler/linearCheck.ml

@@ -430,10 +430,16 @@ and pat_el t (ty, p) v =
 and pat_ t ty p v =
   match p with
   | Pany ->
-      let v = match ty with _, Tprim _ -> Type.Safe | _ -> v in
+      let v = match ty with 
+      | _, Tfun _ (* turning closures off for now *)
+      | _, Tprim _ -> Type.Safe 
+      | _ -> v in
       Env.bind (Type.make_pany (fst ty)) v t
   | Pid id ->
-      let v = match ty with _, Tprim _ -> Type.Safe | _ -> v in
+      let v = match ty with 
+      | _, Tfun _ (* turning closures off for now *)
+      | _, Tprim _ -> Type.Safe 
+      | _ -> v in
       Env.bind id v t
   | Pvalue _ -> t
   | Pvariant (_, p) -> pat t p (make_value v p)
@@ -519,6 +525,8 @@ and expr t (ty, e) = expr_ t [ty] e
 and expr_ t ty = function
   | Eid x ->
       (match ty with
+      (* turning closures off for now *)
+      | [_, Tfun _]
       | [_, Tprim _] ->
 	  Env.bind x Type.Safe t, [Type.Safe]
       | _ -> Env.use x t)
@@ -541,7 +549,16 @@ and expr_ t ty = function
       let t = List.fold_left field t fdl in
       let t, _ = expr t e in
       t, Type.fresh ty
-  | Efield (e, _) -> proj t e
+  | Efield (e, _) -> 
+      (match ty with
+      (* turning closures off for now *)
+      | [_, Tfun _]
+      | [_, Tprim _] -> t, [Type.Safe]
+      | [_, Tapply (x, (_, [_, Tfun _]))] when snd x = Naming.tobs -> 
+	  t, [Type.Safe]
+      | [_, Tapply (x, (_, [_, Tprim _]))] when snd x = Naming.tobs -> 
+	  t, [Type.Safe]
+      | _ -> proj t e)
   | Ematch (e, al) ->
       let t, vl = tuple t e in
       let t' = Env.push t in
@@ -564,7 +581,8 @@ and expr_ t ty = function
       let t = Env.merge t [pos1, t1; pos2, t2] in
       t, Type.unify vl1 vl2
   | Eapply (_, _, x, e) ->
-      let t, _ = Env.use x t in
+(*       let t, _ = Env.use x t in *)
+(* turning this off for now *)
       let t, vl = tuple t e in
       apply ty t e vl
   | Eseq (e1, e2) ->
@@ -578,7 +596,7 @@ and expr_ t ty = function
       let t, _ = expr t f in
       let t, vl = tuple t e in
       let t, vl = Env.partial t vl in
-      t, vl
+      t, vl 
   | Efun (_, obs, p, e) as e_ ->
       let vset = FreeObsVars.expr_ obs t ISet.empty e_ in
       let t = Env.push t in
@@ -600,7 +618,7 @@ and action t vl (p, a) =
   let t, vl = tuple t a in
   (pos, t), vl
 
-and proj t (_, e) =
+and proj t (ty, e) =
   match e with
   | Eid x -> Env.obs x (Env.get (snd x) t) t
   | Efield (e, _) -> proj t e

compiler/llstOfEst.ml

@@ -362,6 +362,8 @@ and block t bl acc =
 
 and ret bls t = function
   | Lreturn _ -> assert false
+  | Return (true, l) -> 
+      [], bls, Llst.Return (true, ty_idl l)
   | Return (b, l) -> 
       let xl = List.map (fun (ty, x) -> ftype_expr ty, Ident.tmp()) l in
       let vl = ty_idl l in

compiler/llstPp.ml

@@ -177,7 +177,7 @@ and expr = function
   | Ebinop (bop, id1, id2) -> binop bop ; o " " ; tid id1 ; o " " ; tid id2 
   | Euop (uop, x) -> unop uop ; o " " ; tid x
   | Etuple (x, l) -> o "{ " ; maybe ty_id x ; o " | " ; 
-      print_list o (fun _ (n, x) -> o "[" ; o (soi n) ; o "]=" ; tid x) ", " l ; o " }"
+      print_list o (fun _ (n, x) -> o "[" ; o (soi n) ; o "]=" ; ty_id x) ", " l ; o " }"
   | Efield (x, y) -> tid x ; o "." ; o (soi y)
   | Eapply (fk, b, x, l) -> 
       if b then o "tail " else () ; 

compiler/main.ml

@@ -183,10 +183,10 @@ let _ =
   if !dump_ist then
     IstPp.program ist;
   let est = EstOfIst.program ist in
-  if !dump_est then
-    EstPp.program est ;
   let est = EstCompile.program est in
   let est = EstNormalizePatterns.program est in 
+  if !dump_est then
+    EstPp.program est ;
   let llst = LlstOfEst.program est in
   let llst = LlstOptim.inline llst in 
   let llst = LlstFree.program llst in  

compiler/naming.ml

@@ -651,16 +651,26 @@ and expr_ genv env p e =
       Nast.Elet (p, k e1, e2)
   | Eif (e1, e2, e3) -> Nast.Eif (k e1, k e2, k e3)
   | Efun (fk, obs, idl, e) ->
-      let env, idl = tpat_list genv env idl in
-      let e = expr genv env e in
-      Nast.Efun (fk, obs, idl, e)
+(*      let env, idl = tpat_list genv env idl in
+      let e = expr genv env e in 
+      Nast.Efun (fk, obs, idl, e) *)
+      begin
+	Error.pos p;
+	Printf.printf "Closures disabled\n";
+	exit 2
+      end
   | Eapply ((_, Eid (_, "free")), e) ->
       (match e with
       | [_, Eid y] -> Nast.Efree (Env.value env y)
       | (p, _) :: _ -> Error.free_expects_id p
       | _ -> assert false)
   | Eapply ((_, Eid (_, "partial")), el) ->
-      Nast.Epartial (List.map k el)
+(*      Nast.Epartial (List.map k el) *)
+      begin
+	Error.pos p;
+	Printf.printf "Closures disabled\n";
+	exit 2
+      end
   | Eapply (e, el) -> Nast.Eapply (k e, List.map k el)
   | Erecord fdl -> Nast.Erecord (List.map (field genv env) fdl)
   | Efield (e, v) -> Nast.Efield (k e, Env.field env v)

compiler/nastCheck.ml

@@ -220,9 +220,47 @@ module CheckRestrict = struct
   let rec program mdl = 
     List.iter module_ mdl
 
-  and module_ md = 
+  and module_ md =
+    List.iter decl md.md_decls;
     List.iter def md.md_defs
 
+  and decl = function
+    | Dtype l -> List.iter (fun (_, ty) -> type_expr ty) l
+    | Dval _ -> ()
+
+  and type_expr (_, ty) = type_expr_ ty
+  and type_expr_ = function
+    | Tany
+    | Tprim _
+    | Tvar _
+    | Tid _
+    | Tpath _ -> ()
+    | Tapply (ty, tyl) -> type_expr ty; List.iter type_expr tyl
+    | Ttuple tyl -> List.iter type_expr tyl
+    | Tfun (_, ty1, ty2) ->
+	type_expr ty1;
+	type_expr ty2
+    | Talgebric m -> 
+	IMap.iter (
+	fun _ (_, ty) -> 
+	  match ty with 
+	  | None -> () 
+	  | Some ty -> type_expr ty
+       ) m
+    | Trecord m -> IMap.iter check_tfield m
+    | Tabbrev ty 
+    | Tabs (_, ty) -> type_expr ty
+    | Tabstract -> ()
+
+  and check_tfield _ (_, ty) =
+    match ty with
+    | p, Ttuple [ty] -> type_expr ty
+    | p, Ttuple _ ->
+	Error.pos p;
+	Printf.fprintf stderr "tuple in fields disabled\n";
+	exit 2
+    | ty -> type_expr ty
+
   and def (_, p, e) = 
     List.iter pat p ;
     expr e

compiler/recordCheck.ml

@@ -139,9 +139,9 @@ and check_field pos x (a, ty) =
 let rec type_expr_list (_, tyl) = List.map type_expr tyl
 and type_expr (_, ty) = type_expr_ ty
 and type_expr_ = function
-  | Tprim _ -> P
+  | Tprim _ | Tfun _ -> P
   | Tany
-  | Tvar _ | Tfun _ -> A
+  | Tvar _  -> A
   | Tapply ((_, x), (_, [ty])) when x = Naming.tobs -> A
   | Tid (_, x)
   | Tapply ((_, x), _) -> Rid x
@@ -151,7 +151,7 @@ let read_only pos = function
   | Write _ -> Error.field_no_val pos
 
 let free_field t pos v (x, ty) =
-  if ty = [P]
+  if not (is_pointer ty)
   then ()
   else match x with
   | Read -> Error.cannot_free_field pos v
@@ -205,7 +205,6 @@ and def t (_, x, ((tyl, _) as p), e) =
 and pat t (_, ptl) tl = List.fold_left (pat_tuple tl) t ptl
 and pat_tuple tl t (_, pel) = List.fold_left2 pat_el t pel tl
 and pat_el t (_, p) ty =
-
   pat_ t p ty
 
 and pat_ t p ty =