diff options
| -rw-r--r-- | bytecomp/bytegen.ml | 150 | ||||
| -rw-r--r-- | bytecomp/emitcode.ml | 32 | ||||
| -rw-r--r-- | bytecomp/instruct.ml | 12 | ||||
| -rw-r--r-- | bytecomp/instruct.mli | 18 | ||||
| -rw-r--r-- | bytecomp/matching.ml | 66 | ||||
| -rw-r--r-- | bytecomp/printinstr.ml | 11 | ||||
| -rw-r--r-- | bytecomp/symtable.ml | 3 | ||||
| -rw-r--r-- | bytecomp/translclass.ml | 5 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 80 | ||||
| -rw-r--r-- | bytecomp/translcore.mli | 1 | ||||
| -rw-r--r-- | bytecomp/typeopt.ml | 77 | ||||
| -rw-r--r-- | bytecomp/typeopt.mli | 19 | ||||
| -rw-r--r-- | byterun/Makefile | 2 | ||||
| -rw-r--r-- | byterun/alloc.c | 28 | ||||
| -rw-r--r-- | byterun/array.c | 187 | ||||
| -rw-r--r-- | byterun/exec.h | 2 | ||||
| -rw-r--r-- | byterun/fix_code.c | 12 | ||||
| -rw-r--r-- | byterun/instrtrace.c | 4 | ||||
| -rw-r--r-- | byterun/instruct.h | 12 | ||||
| -rw-r--r-- | byterun/intern.c | 5 | ||||
| -rw-r--r-- | byterun/interp.c | 96 | ||||
| -rw-r--r-- | byterun/reverse.h | 7 |
22 files changed, 607 insertions, 222 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 198144913..27a25ed25 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -30,13 +30,19 @@ let new_label () = (**** Operations on compilation environments. ****) let empty_env = - { ce_stack = Ident.empty; ce_heap = Ident.empty } + { ce_stack = Ident.empty; ce_heap = Ident.empty; ce_rec = Ident.empty } (* Add a stack-allocated variable *) let add_var id pos env = { ce_stack = Ident.add id pos env.ce_stack; - ce_heap = env.ce_heap } + ce_heap = env.ce_heap; + ce_rec = env.ce_rec } + +let rec add_vars idlist pos env = + match idlist with + [] -> env + | id :: rem -> add_vars rem (pos + 1) (add_var id pos env) (**** Examination of the continuation ****) @@ -186,8 +192,16 @@ and sz_staticfail = ref 0 (* Function bodies that remain to be compiled *) -let functions_to_compile = - (Stack.create () : (Ident.t list * lambda * label * Ident.t list) Stack.t) +type function_to_compile = + { params: Ident.t list; (* function parameters *) + body: lambda; (* the function body *) + label: label; (* the label of the function entry *) + free_vars: Ident.t list; (* free variables of the function *) + num_defs: int; (* number of mutually recursive definitions *) + rec_vars: Ident.t list; (* mutually recursive fn names *) + rec_pos: int } (* rank in recursive definition *) + +let functions_to_compile = (Stack.create () : function_to_compile Stack.t) (* Name of current compilation unit (for debugging events) *) @@ -212,6 +226,10 @@ let rec comp_expr env exp sz cont = let pos = Ident.find_same id env.ce_heap in Kenvacc(pos) :: cont with Not_found -> + try + let ofs = Ident.find_same id env.ce_rec in + Koffsetclosure(ofs) :: cont + with Not_found -> Ident.print id; print_newline(); fatal_error "Bytegen.comp_expr: var" end @@ -252,40 +270,59 @@ let rec comp_expr env exp sz cont = | Lfunction(kind, params, body) -> (* assume kind = Curried *) let lbl = new_label() in let fv = IdentSet.elements(free_variables exp) in - Stack.push (params, body, lbl, fv) functions_to_compile; + let to_compile = + { params = params; body = body; label = lbl; + free_vars = fv; num_defs = 1; rec_vars = []; rec_pos = 0 } in + Stack.push to_compile functions_to_compile; comp_args env (List.map (fun n -> Lvar n) fv) sz (Kclosure(lbl, List.length fv) :: cont) | Llet(str, id, arg, body) -> comp_expr env arg sz (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1) (add_pop 1 cont)) - | Lletrec(([id, Lfunction(kind, params, funct_body)] as decl), let_body) -> - let lbl = new_label() in - let fv = - IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in - Stack.push (params, funct_body, lbl, id :: fv) functions_to_compile; - comp_args env (List.map (fun n -> Lvar n) fv) sz - (Kclosurerec(lbl, List.length fv) :: Kpush :: - (comp_expr (add_var id (sz+1) env) let_body (sz+1) - (add_pop 1 cont))) | Lletrec(decl, body) -> let ndecl = List.length decl in - let decl_size = - List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in - let rec comp_decl new_env sz i = function - [] -> - comp_expr new_env body sz (add_pop ndecl cont) - | (id, exp, blocksize) :: rem -> - comp_expr new_env exp sz - (Kpush :: Kacc i :: Kupdate blocksize :: - comp_decl new_env sz (i-1) rem) in - let rec comp_init new_env sz = function - [] -> - comp_decl new_env sz ndecl decl_size - | (id, exp, blocksize) :: rem -> - Kdummy blocksize :: Kpush :: - comp_init (add_var id (sz+1) new_env) (sz+1) rem in - comp_init env sz decl_size + if List.for_all (function (_, Lfunction(_,_,_)) -> true | _ -> false) + decl then begin + (* let rec of functions *) + let fv = + IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in + let rec_idents = List.map (fun (id, lam) -> id) decl in + let rec comp_fun pos = function + [] -> [] + | (id, Lfunction(kind, params, body)) :: rem -> + let lbl = new_label() in + let to_compile = + { params = params; body = body; label = lbl; free_vars = fv; + num_defs = ndecl; rec_vars = rec_idents; rec_pos = pos} in + Stack.push to_compile functions_to_compile; + lbl :: comp_fun (pos + 1) rem + | _ -> assert false in + let lbls = comp_fun 0 decl in + let num_funcs = List.length lbls in + comp_args env (List.map (fun n -> Lvar n) fv) sz + (Kclosurerec(lbls, List.length fv) :: + (comp_expr (add_vars rec_idents (sz+1) env) body (sz + ndecl) + (add_pop ndecl cont))) + end else begin + let decl_size = + List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in + let rec comp_decl new_env sz i = function + [] -> + comp_expr new_env body sz (add_pop ndecl cont) + | (id, exp, blocksize) :: rem -> + comp_expr new_env exp sz + (Kpush :: Kacc i :: Kccall("update_dummy", 2) :: + comp_decl new_env sz (i-1) rem) in + let rec comp_init new_env sz = function + [] -> + comp_decl new_env sz ndecl decl_size + | (id, exp, blocksize) :: rem -> + Kconst(Const_base(Const_int blocksize)) :: + Kccall("alloc_dummy", 1) :: Kpush :: + comp_init (add_var id (sz+1) new_env) (sz+1) rem in + comp_init env sz decl_size + end | Lprim(Pidentity, [arg]) -> comp_expr env arg sz cont | Lprim(Pnot, [arg]) -> @@ -329,6 +366,19 @@ let rec comp_expr env exp sz cont = when n >= immed_min & n <= immed_max -> let ofs = if prim == Paddint then n else -n in comp_expr env arg sz (Koffsetint ofs :: cont) + | Lprim(Pmakearray kind, args) -> + begin match kind with + Pintarray | Paddrarray -> + comp_args env args sz (Kmakeblock(List.length args, 0) :: cont) + | Pfloatarray -> + comp_args env args sz (Kmakefloatblock(List.length args) :: cont) + | Pgenarray -> + if args = [] + then Kmakeblock(0, 0) :: cont + else comp_args env args sz + (Kmakeblock(List.length args, 0) :: + Kccall("make_array", 1) :: cont) + end | Lprim(p, args) -> let instr = match p with @@ -338,8 +388,8 @@ let rec comp_expr env exp sz cont = | Pmakeblock(tag, mut) -> Kmakeblock(List.length args, tag) | Pfield n -> Kgetfield n | Psetfield(n, ptr) -> Ksetfield n - | Pfloatfield n -> Kgetfield n - | Psetfloatfield n -> Ksetfield n + | Pfloatfield n -> Kgetfloatfield n + | Psetfloatfield n -> Ksetfloatfield n | Pccall p -> Kccall(p.prim_name, p.prim_arity) | Pnegint -> Knegint | Paddint -> Kaddint @@ -374,12 +424,19 @@ let rec comp_expr env exp sz cont = | Pstringsets -> Kccall("string_set", 3) | Pstringrefu -> Kgetstringchar | Pstringsetu -> Ksetstringchar - | Pmakearray kind -> Kmakeblock(List.length args, 0) | Parraylength kind -> Kvectlength - | Parrayrefs kind -> Kccall("array_get", 2) - | Parraysets kind -> Kccall("array_set", 3) - | Parrayrefu kind -> Kgetvectitem - | Parraysetu kind -> Ksetvectitem + | Parrayrefs Pgenarray -> Kccall("array_get", 2) + | Parrayrefs Pfloatarray -> Kccall("array_get_float", 2) + | Parrayrefs _ -> Kccall("array_get_addr", 2) + | Parraysets Pgenarray -> Kccall("array_set", 3) + | Parraysets Pfloatarray -> Kccall("array_set_float", 3) + | Parraysets _ -> Kccall("array_set_addr", 3) + | Parrayrefu Pgenarray -> Kccall("array_unsafe_get", 2) + | Parrayrefu Pfloatarray -> Kccall("array_unsafe_get_float", 2) + | Parrayrefu _ -> Kgetvectitem + | Parraysetu Pgenarray -> Kccall("array_unsafe_set", 3) + | Parraysetu Pfloatarray -> Kccall("array_unsafe_set_float", 3) + | Parraysetu _ -> Ksetvectitem | Pbittest -> Kccall("bitvect_test", 2) | _ -> fatal_error "Bytegen.comp_expr: prim" in comp_args env args sz (instr :: cont) @@ -545,20 +602,21 @@ and comp_binary_test env cond ifso ifnot sz cont = (**** Compilation of functions ****) -let comp_function (params, fun_body, entry_lbl, free_vars) cont = - let arity = List.length params in - let rec pos_args pos delta = function +let comp_function tc cont = + let arity = List.length tc.params in + let rec positions pos delta = function [] -> Ident.empty - | id :: rem -> Ident.add id pos (pos_args (pos+delta) delta rem) in + | id :: rem -> Ident.add id pos (positions (pos + delta) delta rem) in let env = - { ce_stack = pos_args arity (-1) params; - ce_heap = pos_args 0 1 free_vars } in + { ce_stack = positions arity (-1) tc.params; + ce_heap = positions (2 * (tc.num_defs - tc.rec_pos) - 1) 1 tc.free_vars; + ce_rec = positions (-2 * tc.rec_pos) 2 tc.rec_vars } in let cont1 = - comp_expr env fun_body arity (Kreturn arity :: cont) in + comp_expr env tc.body arity (Kreturn arity :: cont) in if arity > 1 then - Krestart :: Klabel entry_lbl :: Kgrab(arity - 1) :: cont1 + Krestart :: Klabel tc.label :: Kgrab(arity - 1) :: cont1 else - Klabel entry_lbl :: cont1 + Klabel tc.label :: cont1 let comp_remainder cont = let c = ref cont in diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 0c6b11ce6..6ade90d71 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -159,7 +159,9 @@ let emit_instr = function | Kacc n -> if n < 8 then out(opACC0 + n) else (out opACC; out_int n) | Kenvacc n -> - if n < 4 then out(opENVACC1 + n) else (out opENVACC; out_int (n+1)) + if n >= 1 && n < 4 + then out(opENVACC1 + n - 1) + else (out opENVACC; out_int n) | Kpush -> out opPUSH | Kpop n -> @@ -176,7 +178,14 @@ let emit_instr = function | Krestart -> out opRESTART | Kgrab n -> out opGRAB; out_int n | Kclosure(lbl, n) -> out opCLOSURE; out_int n; out_label lbl - | Kclosurerec(lbl, n) -> out opCLOSUREREC; out_int n; out_label lbl + | Kclosurerec(lbls, n) -> + out opCLOSUREREC; out_int (List.length lbls); out_int n; + let org = !out_position in + List.iter (out_label_with_orig org) lbls + | Koffsetclosure ofs -> + if ofs = -2 || ofs = 0 || ofs = 2 + then out (opOFFSETCLOSURE0 + ofs / 2) + else (out opOFFSETCLOSURE; out_int ofs) | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q | Ksetglobal q -> out opSETGLOBAL; slot_for_setglobal q | Kconst sc -> @@ -205,9 +214,10 @@ let emit_instr = function if n < 4 then out(opGETFIELD0 + n) else (out opGETFIELD; out_int n) | Ksetfield n -> if n < 4 then out(opSETFIELD0 + n) else (out opSETFIELD; out_int n) - | Kdummy n -> - if n = 0 then out opATOM0 else (out opDUMMY; out_int n) - | Kupdate n -> out opUPDATE + | Kmakefloatblock(n) -> + if n = 0 then out opATOM0 else (out opMAKEFLOATBLOCK; out_int n) + | Kgetfloatfield n -> out opGETFLOATFIELD; out_int n + | Ksetfloatfield n -> out opSETFLOATFIELD; out_int n | Kvectlength -> out opVECTLENGTH | Kgetvectitem -> out opGETVECTITEM | Ksetvectitem -> out opSETVECTITEM @@ -257,8 +267,14 @@ let rec emit = function if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); emit c | Kpush :: Kenvacc n :: c -> - if n < 4 then out(opPUSHENVACC1 + n) - else (out opPUSHENVACC; out_int (n+1)); + if n >= 1 && n < 4 + then out(opPUSHENVACC1 + n - 1) + else (out opPUSHENVACC; out_int n); + emit c + | Kpush :: Koffsetclosure ofs :: c -> + if ofs = -2 || ofs = 0 || ofs = 2 + then out(opPUSHOFFSETCLOSURE0 + ofs / 2) + else (out opPUSHOFFSETCLOSURE; out_int ofs); emit c | Kpush :: Kgetglobal id :: Kgetfield n :: c -> out opPUSHGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c @@ -286,7 +302,7 @@ let rec emit = function (Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c -> emit (Kpush :: instr1 :: instr2 :: ev :: c) | Kpush :: (Kevent {ev_kind = Event_before} as ev) :: - (Kacc _ | Kenvacc _ | Kgetglobal _ | Kconst _ as instr) :: c -> + (Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr) :: c -> emit (Kpush :: instr :: ev :: c) | Kgetglobal id :: Kgetfield n :: c -> out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index d37523d59..7357d1f86 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -15,8 +15,8 @@ open Lambda type compilation_env = { ce_stack: int Ident.tbl; - ce_heap: int Ident.tbl } - + ce_heap: int Ident.tbl; + ce_rec: int Ident.tbl } type debug_event = { mutable ev_pos: int; (* Position in bytecode *) @@ -60,15 +60,17 @@ type instruction = | Krestart | Kgrab of int (* number of arguments *) | Kclosure of label * int - | Kclosurerec of label * int + | Kclosurerec of label list * int + | Koffsetclosure of int | Kgetglobal of Ident.t | Ksetglobal of Ident.t | Kconst of structured_constant | Kmakeblock of int * int (* size, tag *) + | Kmakefloatblock of int | Kgetfield of int | Ksetfield of int - | Kdummy of int - | Kupdate of int + | Kgetfloatfield of int + | Ksetfloatfield of int | Kvectlength | Kgetvectitem | Ksetvectitem diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index 73aaa7309..a0050b1b0 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -19,13 +19,19 @@ open Lambda type compilation_env = { ce_stack: int Ident.tbl; (* Positions of variables in the stack *) - ce_heap: int Ident.tbl } (* Structure of the heap-allocated env *) + ce_heap: int Ident.tbl; (* Structure of the heap-allocated env *) + ce_rec: int Ident.tbl } (* Functions bound by the same let rec *) (* The ce_stack component gives locations of variables residing in the stack. The locations are offsets w.r.t. the origin of the stack frame. The ce_heap component gives the positions of variables residing in the - heap-allocated environment. *) + heap-allocated environment. + The ce_rec component associate offsets to identifiers for functions + bound by the same let rec as the current function. The offsets + are used by the OFFSETCLOSURE instruction to recover the closure + pointer of the desired function from the env register (which + points to the closure for the current function). *) (* Debugging events *) @@ -73,15 +79,17 @@ type instruction = | Krestart | Kgrab of int (* number of arguments *) | Kclosure of label * int - | Kclosurerec of label * int + | Kclosurerec of label list * int + | Koffsetclosure of int | Kgetglobal of Ident.t | Ksetglobal of Ident.t | Kconst of structured_constant | Kmakeblock of int * int (* size, tag *) + | Kmakefloatblock of int | Kgetfield of int | Ksetfield of int - | Kdummy of int (* block size *) - | Kupdate of int (* block size *) + | Kgetfloatfield of int + | Ksetfloatfield of int | Kvectlength | Kgetvectitem | Ksetvectitem diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 57db9264d..e560ffb79 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -57,7 +57,8 @@ let rec name_pattern default = function (* To remove aliases and bind named components *) let any_pat = - {pat_desc = Tpat_any; pat_loc = Location.none; pat_type = Ctype.none} + { pat_desc = Tpat_any; pat_loc = Location.none; + pat_type = Ctype.none; pat_env = Env.empty } let simplify_matching m = match m.args with @@ -94,18 +95,23 @@ let divide_constant {cases = cl; args = al} = (* Matching against a constructor *) +let make_field_args binding_kind arg first_pos last_pos argl = + let rec make_args pos = + if pos > last_pos + then argl + else (Lprim(Pfield pos, [arg]), binding_kind) :: make_args (pos + 1) + in make_args first_pos + let make_constr_matching cstr = function [] -> fatal_error "Matching.make_constr_matching" | ((arg, mut) :: argl) -> - let (first_pos, last_pos) = + let newargs = match cstr.cstr_tag with - Cstr_constant _ | Cstr_block _ -> (0, cstr.cstr_arity - 1) - | Cstr_exception _ -> (1, cstr.cstr_arity) in - let rec make_args pos = - if pos > last_pos - then argl - else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in - {cases = []; args = make_args first_pos} + Cstr_constant _ | Cstr_block _ -> + make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl + | Cstr_exception _ -> + make_field_args Alias arg 1 cstr.cstr_arity argl in + {cases = []; args = newargs} let divide_constructor {cases = cl; args = al} = let rec divide = function @@ -205,6 +211,24 @@ let divide_orpat = function | _ -> fatal_error "Matching.divide_orpat" +(* Matching against an array pattern *) + +let make_array_matching len = function + [] -> fatal_error "Matching.make_array_matching" + | ((arg, mut) :: argl) -> + {cases = []; args = make_field_args StrictOpt arg 0 (len - 1) argl} + +let divide_array {cases = cl; args = al} = + let rec divide = function + ({pat_desc = Tpat_array(args)} :: patl, action) :: rem -> + let len = List.length args in + let (constructs, others) = divide rem in + (add (make_array_matching len) constructs len (args @ patl, action) al, + others) + | cl -> + ([], {cases = cl; args = al}) + in divide cl + (* To combine sub-matchings together *) let combine_var (lambda1, total1) (lambda2, total2) = @@ -321,7 +345,7 @@ let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) = sw_blocks = nonconsts; sw_checked = false}) in if total1 - & List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts + && List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts then (lambda1, true) else (Lcatch(lambda1, lambda2), total2) end @@ -329,6 +353,23 @@ let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) = let combine_orpat (lambda1, total1) (lambda2, total2) (lambda3, total3) = (Lcatch(Lsequence(lambda1, lambda2), lambda3), total3) +let combine_array kind arg (len_lambda_list, total1) (lambda2, total2) = + let lambda1 = + match len_lambda_list with + [] -> Lstaticfail (* does not happen? *) + | [n, act] -> + Lifthenelse(Lprim(Pintcomp Ceq, + [Lprim(Parraylength kind, [arg]); + Lconst(Const_base(Const_int n))]), + act, Lstaticfail) + | _ -> + let max_len = + List.fold_left (fun m (n, act) -> max m n) 0 len_lambda_list in + Lswitch(Lprim(Parraylength kind, [arg]), + {sw_numblocks = 0; sw_blocks = []; sw_checked = true; + sw_numconsts = max_len + 1; sw_consts = len_lambda_list}) in + (Lcatch(lambda1, lambda2), total2) + (* Insertion of debugging events *) let rec event_branch repr lam = @@ -407,6 +448,11 @@ let rec compile_match repr m = let (records, others) = divide_record lbl.lbl_all pm in combine_var (compile_match repr records) (compile_match repr others) + | Tpat_array(patl) -> + let (arrays, others) = divide_array pm in + combine_array (Typeopt.array_pattern_kind pat) newarg + (compile_list arrays) + (compile_match repr others) | Tpat_or(pat1, pat2) -> (* Avoid duplicating the code of the action *) let (or_match, remainder_line, others) = divide_orpat pm in diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml index 40bc61fc2..973813605 100644 --- a/bytecomp/printinstr.ml +++ b/bytecomp/printinstr.ml @@ -34,8 +34,9 @@ let instruction = function | Kgrab n -> print_string "\tgrab "; print_int n | Kclosure(lbl, n) -> print_string "\tclosure L"; print_int lbl; print_string ", "; print_int n - | Kclosurerec(lbl, n) -> - print_string "\tclosurerec L"; print_int lbl; + | Kclosurerec(lbls, n) -> + print_string "\tclosurerec"; + List.iter (fun lbl -> print_string " "; print_int lbl) lbls; print_string ", "; print_int n | Kgetglobal id -> print_string "\tgetglobal "; Ident.print id | Ksetglobal id -> print_string "\tsetglobal "; Ident.print id @@ -44,10 +45,12 @@ let instruction = function Printlambda.structured_constant cst; close_box() | Kmakeblock(n, m) -> print_string "\tmakeblock "; print_int n; print_string ", "; print_int m + | Kmakefloatblock(n) -> + print_string "\tmakefloatblock "; print_int n | Kgetfield n -> print_string "\tgetfield "; print_int n | Ksetfield n -> print_string "\tsetfield "; print_int n - | Kdummy n -> print_string "\tdummy "; print_int n - | Kupdate n -> print_string "\tupdate"; print_int n + | Kgetfloatfield n -> print_string "\tgetfloatfield "; print_int n + | Ksetfloatfield n -> print_string "\tsetfloatfield "; print_int n | Kvectlength -> print_string "\tvectlength" | Kgetvectitem -> print_string "\tgetvectitem" | Ksetvectitem -> print_string "\tsetvectitem" diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index b575e595c..3f1163e6f 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -169,8 +169,7 @@ let rec transl_const = function fields; block | Const_float_array fields -> - transl_const - (Const_block(0, List.map (fun f -> Const_base(Const_float f)) fields)) + Obj.repr(Array.of_list(List.map (fun f -> float_of_string f) fields)) (* Build the initial table of globals *) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 02086ad28..96bbbd2f1 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -30,9 +30,8 @@ let rec transl_meth_list = (* Instance variable initialization *) let set_inst_var obj var id expr = - Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray), - [Lvar obj; Lvar id; transl_exp expr]) - + let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in + Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr]) let transl_super tbl meths inh_methods rem = List.fold_right diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index fa80e415f..fa5323821 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -20,8 +20,8 @@ open Primitive open Path open Types open Typedtree +open Typeopt open Lambda -open Translobj type error = Illegal_letrec_pat @@ -139,62 +139,11 @@ let primitives_table = create_hashtable 31 [ "%array_safe_set", Parraysets Pgenarray; "%array_unsafe_get", Parrayrefu Pgenarray; "%array_unsafe_set", Parraysetu Pgenarray; - "%obj_size", Parraylength Paddrarray; - "%obj_field", Parrayrefu Paddrarray; - "%obj_set_field", Parraysetu Paddrarray + "%obj_size", Parraylength Pgenarray; + "%obj_field", Parrayrefu Pgenarray; + "%obj_set_field", Parraysetu Pgenarray ] -let has_base_type exp base_ty = - let exp_ty = - Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in - match (Ctype.repr exp_ty, Ctype.repr base_ty) with - {desc = Tconstr(p1, _, _)}, {desc = Tconstr(p2, _, _)} -> Path.same p1 p2 - | (_, _) -> false - -let maybe_pointer arg = - not(has_base_type arg Predef.type_int or has_base_type arg Predef.type_char) - -let array_element_kind env ty = - let ty = Ctype.repr (Ctype.expand_head env ty) in - match ty.desc with - Tvar -> - Pgenarray - | Tconstr(p, args, abbrev) -> - if Path.same p Predef.path_int || Path.same p Predef.path_char then - Pintarray - else if Path.same p Predef.path_float then - Pfloatarray - else if Path.same p Predef.path_string - || Path.same p Predef.path_array then - Paddrarray - else begin - try - match Env.find_type p env with - {type_kind = Type_abstract} -> - Pgenarray - | {type_kind = Type_variant cstrs} - when List.for_all (fun (name, args) -> args = []) cstrs -> - Pintarray - | {type_kind = _} -> - Paddrarray - with Not_found -> - (* This can happen due to e.g. missing -I options, - causing some .cmi files to be unavailable. - Maybe we should emit a warning. *) - Pgenarray - end - | _ -> - Paddrarray - -let array_kind arg = - let ty = Ctype.correct_levels arg.exp_type in - let array_ty = Ctype.expand_head arg.exp_env ty in - match (Ctype.repr array_ty).desc with - Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array -> - array_element_kind arg.exp_env elt_ty - | _ -> - fatal_error "Translcore.array_kind" - let prim_makearray = { prim_name = "make_vect"; prim_arity = 2; prim_alloc = true; prim_native_name = ""; prim_native_float = false } @@ -258,7 +207,7 @@ let check_recursive_lambda idlist lam = let rec check_top = function Lfunction(kind, params, body) as funct -> true | Lprim(Pmakeblock(tag, mut), args) -> List.for_all check args - | Lprim(Pmakearray kind, args) -> List.for_all check args + | Lprim(Pmakearray(Paddrarray|Pintarray), args) -> List.for_all check args | Llet(str, id, arg, body) -> check arg & check_top body | Lletrec(bindings, body) -> List.for_all (fun (id, arg) -> check arg) bindings & check_top body @@ -272,7 +221,7 @@ let check_recursive_lambda idlist lam = | Lletrec(bindings, body) -> List.for_all (fun (id, arg) -> check arg) bindings & check body | Lprim(Pmakeblock(tag, mut), args) -> List.for_all check args - | Lprim(Pmakearray kind, args) -> List.for_all check args + | Lprim(Pmakearray(Paddrarray|Pintarray), args) -> List.for_all check args | Levent (lam, _) -> check lam | lam -> let fv = free_variables lam in @@ -477,7 +426,7 @@ let rec transl_exp e = | Texp_send(expr, met) -> let met_id = match met with - Tmeth_name nm -> meth nm + Tmeth_name nm -> Translobj.meth nm | Tmeth_val id -> id in event_after e (Lsend(Lvar met_id, transl_exp expr, [])) @@ -489,13 +438,14 @@ let rec transl_exp e = transl_setinstvar (transl_path path_self) path expr | Texp_override(path_self, modifs) -> let cpy = Ident.create "copy" in - Llet(Strict, cpy, Lapply(oo_prim "copy", [transl_path path_self]), - List.fold_right - (fun (path, expr) rem -> - Lsequence(transl_setinstvar (Lvar cpy) path expr, - rem)) - modifs - (Lvar cpy)) + Llet(Strict, cpy, + Lapply(Translobj.oo_prim "copy", [transl_path path_self]), + List.fold_right + (fun (path, expr) rem -> + Lsequence(transl_setinstvar (Lvar cpy) path expr, + rem)) + modifs + (Lvar cpy)) | Texp_letmodule(id, modl, body) -> Llet(Strict, id, !transl_module Tcoerce_none modl, transl_exp body) | _ -> diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index d3a1e1a53..86626fa1d 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -20,7 +20,6 @@ open Typedtree open Lambda val name_pattern: string -> (pattern * 'a) list -> Ident.t -val maybe_pointer: expression -> bool val transl_exp: expression -> lambda val transl_let: diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml new file mode 100644 index 000000000..921be0a80 --- /dev/null +++ b/bytecomp/typeopt.ml @@ -0,0 +1,77 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Auxiliaries for type-based optimizations, e.g. array kinds *) + +open Misc +open Asttypes +open Primitive +open Path +open Types +open Typedtree +open Lambda + +let has_base_type exp base_ty = + let exp_ty = + Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in + match (Ctype.repr exp_ty, Ctype.repr base_ty) with + {desc = Tconstr(p1, _, _)}, {desc = Tconstr(p2, _, _)} -> Path.same p1 p2 + | (_, _) -> false + +let maybe_pointer arg = + not(has_base_type arg Predef.type_int or has_base_type arg Predef.type_char) + +let array_element_kind env ty = + let ty = Ctype.repr (Ctype.expand_head env ty) in + match ty.desc with + Tvar -> + Pgenarray + | Tconstr(p, args, abbrev) -> + if Path.same p Predef.path_int || Path.same p Predef.path_char then + Pintarray + else if Path.same p Predef.path_float then + Pfloatarray + else if Path.same p Predef.path_string + || Path.same p Predef.path_array then + Paddrarray + else begin + try + match Env.find_type p env with + {type_kind = Type_abstract} -> + Pgenarray + | {type_kind = Type_variant cstrs} + when List.for_all (fun (name, args) -> args = []) cstrs -> + Pintarray + | {type_kind = _} -> + Paddrarray + with Not_found -> + (* This can happen due to e.g. missing -I options, + causing some .cmi files to be unavailable. + Maybe we should emit a warning. *) + Pgenarray + end + | _ -> + Paddrarray + +let array_kind_gen ty env = + let array_ty = Ctype.expand_head env (Ctype.correct_levels ty) in + match (Ctype.repr array_ty).desc with + Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array -> + array_element_kind env elt_ty + | _ -> + (* This can happen with e.g. Obj.field *) + Pgenarray + +let array_kind exp = array_kind_gen exp.exp_type exp.exp_env + +let array_pattern_kind pat = array_kind_gen pat.pat_type pat.pat_env diff --git a/bytecomp/typeopt.mli b/bytecomp/typeopt.mli new file mode 100644 index 000000000..0f4e856a9 --- /dev/null +++ b/bytecomp/typeopt.mli @@ -0,0 +1,19 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Auxiliaries for type-based optimizations, e.g. array kinds *) + +val has_base_type : Typedtree.expression -> Types.type_expr -> bool +val maybe_pointer : Typedtree.expression -> bool +val array_kind : Typedtree.expression -> Lambda.array_kind +val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind diff --git a/byterun/Makefile b/byterun/Makefile index 2d3f157b9..840a52da4 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -13,7 +13,7 @@ OBJS=interp.o misc.o stacks.o fix_code.o startup.o main.o \ DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o -PRIMS=array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ +PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \ signals.c str.c sys.c terminfo.c callback.c weak.c diff --git a/byterun/alloc.c b/byterun/alloc.c index 4ea4091b5..d16c39267 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -94,7 +94,8 @@ value alloc_array(value (*funct)(char *), char ** arr) Begin_root(result); for (n = 0; n < nbr; n++) { /* The two statements below must be separate because of evaluation - order. */ + order (don't take the address &Field(result, n) before + calling funct, which may cause a GC and move result). */ v = funct(arr[n]); modify(&Field(result, n), v); } @@ -118,3 +119,28 @@ int convert_flag_list(value list, int *flags) } return res; } + +/* For compiling let rec over values */ + +value alloc_dummy(value size) /* ML */ +{ + mlsize_t wosize = Int_val(size); + value result; + mlsize_t i; + + if (wosize == 0) return Atom(0); + result = alloc(wosize, 0); + for (i = 0; i < wosize; i++) Field(result, i) = Val_int(0); + return result; +} + +value update_dummy(value dummy, value newval) /* ML */ +{ + mlsize_t size, i; + size = Wosize_val(newval); + Assert (size == Wosize_val(dummy)); + Tag_val(dummy) = Tag_val(newval); + for (i = 0; i < size; i++) + modify(&Field(dummy, i), Field(newval, i)); + return Val_unit; +} diff --git a/byterun/array.c b/byterun/array.c index 3aa4e5791..cc82716aa 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -19,14 +19,42 @@ #include "misc.h" #include "mlvalues.h" -value array_get(value array, value index) /* ML */ +#ifndef NATIVE_CODE + +value array_get_addr(value array, value index) /* ML */ { long idx = Long_val(index); if (idx < 0 || idx >= Wosize_val(array)) invalid_argument("Array.get"); return Field(array, idx); } -value array_set(value array, value index, value newval) /* ML */ +value array_get_float(value array, value index) /* ML */ +{ + long idx = Long_val(index); + double d; + value res; + + if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) + invalid_argument("Array.get"); + d = Double_field(array, idx); +#define Setup_for_gc +#define Restore_after_gc + Alloc_small(res, Double_wosize, Double_tag); +#undef Setup_for_gc +#undef Restore_after_gc + Store_double_val(res, d); + return res; +} + +value array_get(value array, value index) /* ML */ +{ + if (Tag_val(array) == Double_array_tag) + return array_get_float(array, index); + else + return array_get_addr(array, index); +} + +value array_set_addr(value array, value index, value newval) /* ML */ { long idx = Long_val(index); if (idx < 0 || idx >= Wosize_val(array)) invalid_argument("Array.set"); @@ -34,33 +62,146 @@ value array_set(value array, value index, value newval) /* ML */ return Val_unit; } -value make_vect(value len, value init) /* ML */ +value array_set_float(value array, value index, value newval) /* ML */ +{ + long idx = Long_val(index); + if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) + invalid_argument("Array.set"); + Store_double_field(array, idx, Double_val(newval)); + return Val_unit; +} + +value array_set(value array, value index, value newval) /* ML */ +{ + if (Tag_val(array) == Double_array_tag) + return array_set_float(array, index, newval); + else + return array_set_addr(array, index, newval); +} + +value array_unsafe_get_float(value array, value index) /* ML */ { + double d; value res; - mlsize_t size, i; - size = Long_val(len); - if (size > Max_wosize) invalid_argument("Array.make"); + d = Double_field(array, Long_val(index)); +#define Setup_for_gc +#define Restore_after_gc + Alloc_small(res, Double_wosize, Double_tag); +#undef Setup_for_gc +#undef Restore_after_gc + Store_double_val(res, d); + return res; +} - Begin_root(init); - if (size == 0) { - res = Atom(0); - } - else if (size < Max_young_wosize) { - res = alloc(size, 0); - for (i = 0; i < size; i++) Field(res, i) = init; - } - else if (Is_block(init) && Is_young(init)) { - minor_collection(); - res = alloc_shr(size, 0); - for (i = 0; i < size; i++) Field(res, i) = init; +value array_unsafe_get(value array, value index) /* ML */ +{ + if (Tag_val(array) == Double_array_tag) + return array_unsafe_get_float(array, index); + else + return Field(array, Long_val(index)); +} + +value array_unsafe_set_addr(value array, value index, value newval) /* ML */ +{ + long idx = Long_val(index); + Modify(&Field(array, idx), newval); + return Val_unit; +} + +value array_unsafe_set_float(value array, value index, value newval) /* ML */ +{ + Store_double_field(array, Long_val(index), Double_val(newval)); + return Val_unit; +} + +value array_unsafe_set(value array, value index, value newval) /* ML */ +{ + if (Tag_val(array) == Double_array_tag) + return array_unsafe_set_float(array, index, newval); + else + return array_unsafe_set_addr(array, index, newval); +} + +#endif + +value make_vect(value len, value init) /* ML */ +{ + value res; + mlsize_t size, wsize, i; + double d; + + size = Long_val(len); + if (size == 0) { + res = Atom(0); + } + else if (Is_block(init) && Tag_val(init) == Double_tag) { + d = Double_val(init); + wsize = size * Double_wosize; + if (wsize > Max_wosize) invalid_argument("Array.new"); + if (wsize < Max_young_wosize) { + res = alloc(wsize, Double_array_tag); + } else { + res = alloc_shr(wsize, Double_array_tag); res = check_urgent_gc (res); } - else { - res = alloc_shr(size, 0); - for (i = 0; i < size; i++) initialize(&Field(res, i), init); - res = check_urgent_gc (res); + for (i = 0; i < size; i++) { + Store_double_field(res, i, d); } - End_roots(); + } else { + if (size > Max_wosize) invalid_argument("Array.new"); + Begin_root(init); + if (size < Max_young_wosize) { + res = alloc(size, 0); + for (i = 0; i < size; i++) Field(res, i) = init; + } + else if (Is_block(init) && Is_young(init)) { + minor_collection(); + res = alloc_shr(size, 0); + for (i = 0; i < size; i++) Field(res, i) = init; + res = check_urgent_gc (res); + } + else { + res = alloc_shr(size, 0); + for (i = 0; i < size; i++) initialize(&Field(res, i), init); + res = check_urgent_gc (res); + } + End_roots(); + } return res; } + +value make_array(value init) /* ML */ +{ + mlsize_t wsize, size, i; + value v, res; + + size = Wosize_val(init); + if (size == 0) { + return init; + } else { + v = Field(init, 0); + if (Is_long(v) || Tag_val(v) != Double_tag) { + return init; + } else { + Assert(size < Max_young_wosize); + wsize = size * Double_wosize; + Begin_root(init); + res = alloc(wsize, Double_array_tag); + for (i = 0; i < size; i++) { + Store_double_field(res, i, Double_val(Field(init, i))); + } + End_roots(); + return res; + } + } +} + +#ifdef NATIVE_CODE + +void array_bound_error(void) +{ + fatal_error("Fatal error: out-of-bound access in array or string\n"); +} + +#endif diff --git a/byterun/exec.h b/byterun/exec.h index a8d81bcf8..7a28867e2 100644 --- a/byterun/exec.h +++ b/byterun/exec.h @@ -39,5 +39,5 @@ struct exec_trailer { /* Magic number for this release */ -#define EXEC_MAGIC "Caml1999X002" +#define EXEC_MAGIC "Caml1999X003" diff --git a/byterun/fix_code.c b/byterun/fix_code.c index 7cdf64547..1ea06568e 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -98,13 +98,15 @@ void thread_code (code_t code, asize_t len) l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] = l[GRAB] = l[PUSHGETGLOBAL] = l[GETGLOBAL] = l[SETGLOBAL] = l[PUSHATOM] = l[ATOM] = l[MAKEBLOCK1] = l[MAKEBLOCK2] = - l[MAKEBLOCK3] = l[GETFIELD] = l[SETFIELD] = l[DUMMY] = + l[MAKEBLOCK3] = l[MAKEFLOATBLOCK] = l[GETFIELD] = + l[GETFLOATFIELD] = l[SETFIELD] = l[SETFLOATFIELD] = l[BRANCH] = l[BRANCHIF] = l[BRANCHIFNOT] = l[PUSHTRAP] = l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] = - l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = l[OFFSETREF] = 1; + l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = + l[OFFSETREF] = l[OFFSETCLOSURE] = l[PUSHOFFSETCLOSURE] = 1; /* Instructions with two operands */ - l[APPTERM] = l[CLOSURE] = l[CLOSUREREC] = l[PUSHGETGLOBALFIELD] = + l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] = l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = 2; len /= sizeof(opcode_t); @@ -120,6 +122,10 @@ void thread_code (code_t code, asize_t len) uint32 const_size = sizes & 0xFFFF; uint32 block_size = sizes >> 16; p += const_size + block_size; + } else if (instr == CLOSUREREC) { + uint32 nfuncs = *p++; + p++; /* skip nvars */ + p += nfuncs; } else { p += l[instr]; } diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index a4dfb9e45..c53590686 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -44,9 +44,11 @@ void disasm_instr(pc) case APPTERM1: case APPTERM2: case APPTERM3: case RETURN: case GRAB: case PUSHGETGLOBAL: case GETGLOBAL: case SETGLOBAL: case PUSHATOM: case ATOM: case MAKEBLOCK1: case MAKEBLOCK2: - case MAKEBLOCK3: case GETFIELD: case SETFIELD: case DUMMY: + case MAKEBLOCK3: case MAKEFLOATBLOCK: + case GETFIELD: case SETFIELD: case GETFLOATFIELD: case SETFLOATFIELD: case BRANCH: case BRANCHIF: case BRANCHIFNOT: case PUSHTRAP: case CONSTINT: case PUSHCONSTINT: case OFFSETINT: case OFFSETREF: + case OFFSETCLOSURE: case PUSHOFFSETCLOSURE: printf(" %d\n", pc[0]); break; /* Instructions with two operands */ case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD: diff --git a/byterun/instruct.h b/byterun/instruct.h index ec98d8098..4fb5425d8 100644 --- a/byterun/instruct.h +++ b/byterun/instruct.h @@ -25,14 +25,16 @@ enum instructions { APPTERM, APPTERM1, APPTERM2, APPTERM3, RETURN, RESTART, GRAB, CLOSURE, CLOSUREREC, + OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, + PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, + PUSHOFFSETCLOSURE2, PUSHOFFSETCLOSURE, GETGLOBAL, PUSHGETGLOBAL, GETGLOBALFIELD, PUSHGETGLOBALFIELD, SETGLOBAL, ATOM0, ATOM, PUSHATOM0, PUSHATOM, - MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, - GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, - SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, - DUMMY, UPDATE, + MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEFLOATBLOCK, + GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, GETFLOATFIELD, + SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, SETFLOATFIELD, VECTLENGTH, GETVECTITEM, SETVECTITEM, - GETSTRINGCHAR, SETSTRINGCHAR, + GETSTRINGCHAR, SETSTRINGCHAR, BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT, PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS, C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN, diff --git a/byterun/intern.c b/byterun/intern.c index 01a5bc62f..6c79996b1 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -184,7 +184,6 @@ static void intern_rec(value *dest) case CODE_DOUBLE_ARRAY8_BIG: len = read8u(); read_double_array: -#ifdef NATIVE_CODE if (sizeof(double) != 8) { intern_cleanup(); invalid_argument("input_value: non-standard floats"); @@ -200,10 +199,6 @@ static void intern_rec(value *dest) mlsize_t i; for (i = 0; i < len; i++) Reverse_double((value)((double *)v + i)); } -#else - intern_cleanup(); - failwith("input_value: cannot read float array"); -#endif break; case CODE_DOUBLE_ARRAY32_LITTLE: case CODE_DOUBLE_ARRAY32_BIG: diff --git a/byterun/interp.c b/byterun/interp.c index d9c8802a8..84c396742 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -461,26 +461,60 @@ value interprete(code_t prog, asize_t prog_size) if (nvars > 0) *--sp = accu; Alloc_small(accu, 1 + nvars, Closure_tag); Code_val(accu) = pc + *pc; + pc++; for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; sp += nvars; - pc++; Next; } Instruct(CLOSUREREC): { + int nfuncs = *pc++; int nvars = *pc++; int i; + value * p; if (nvars > 0) *--sp = accu; - Alloc_small(accu, 2 + nvars, Closure_tag); - Code_val(accu) = pc + *pc; - Field(accu, 1) = Val_int(0); - for (i = 0; i < nvars; i++) Field(accu, i + 2) = sp[i]; + Alloc_small(accu, nfuncs * 2 - 1 + nvars, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++) { + *p++ = sp[i]; + } sp += nvars; - modify(&Field(accu, 1), accu); - pc++; + p = &Field(accu, 0); + *p = (value) (pc + pc[0]); + *--sp = accu; + p++; + for (i = 1; i < nfuncs; i++) { + *p = Make_header(i * 2, Infix_tag, Black); /* color irrelevant? */ + p++; + *p = (value) (pc + pc[i]); + *--sp = (value) p; + p++; + } + pc += nfuncs; Next; } + Instruct(PUSHOFFSETCLOSURE): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSURE): + accu = env + *pc++ * sizeof(value); Next; + + Instruct(PUSHOFFSETCLOSUREM2): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSUREM2): + accu = env - 2 * sizeof(value); Next; + Instruct(PUSHOFFSETCLOSURE0): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSURE0): + accu = env; Next; + Instruct(PUSHOFFSETCLOSURE2): + *--sp = accu; /* fallthrough */ + Instruct(OFFSETCLOSURE2): + accu = env + 2 * sizeof(value); Next; + + +/* Access to global variables */ + Instruct(PUSHGETGLOBAL): *--sp = accu; /* Fallthrough */ @@ -560,6 +594,17 @@ value interprete(code_t prog, asize_t prog_size) accu = block; Next; } + Instruct(MAKEFLOATBLOCK): { + mlsize_t size = *pc++; + mlsize_t i; + value block; + Alloc_small(block, size * Double_wosize, Double_array_tag); + Store_double_field(block, 0, Double_val(accu)); + for (i = 1; i < size; i++) + Store_double_field(block, i, Double_val(*sp++)); + accu = block; + Next; + } /* Access to components of blocks */ @@ -573,6 +618,13 @@ value interprete(code_t prog, asize_t prog_size) accu = Field(accu, 3); Next; Instruct(GETFIELD): accu = Field(accu, *pc); pc++; Next; + Instruct(GETFLOATFIELD): { + double d = Double_field(accu, *pc); + Alloc_small(accu, Double_wosize, Double_tag); + Double_val(accu) = d; + pc++; + Next; + } Instruct(SETFIELD0): modify_dest = &Field(accu, 0); @@ -598,33 +650,21 @@ value interprete(code_t prog, asize_t prog_size) pc++; modify_newval = *sp++; goto modify; - -/* For recursive definitions */ - - Instruct(DUMMY): { - int size = *pc++; - Alloc_small(accu, size, 0); - while (size--) Field(accu, size) = Val_long(0); - Next; - } - Instruct(UPDATE): { - value newval = *sp++; - mlsize_t size, n; - size = Wosize_val(newval); - Assert(size == Wosize_val(accu)); - Tag_val(accu) = Tag_val(newval); - for (n = 0; n < size; n++) { - modify(&Field(accu, n), Field(newval, n)); - } + Instruct(SETFLOATFIELD): + Store_double_field(accu, *pc, Double_val(*sp)); accu = Val_unit; + sp++; + pc++; Next; - } /* Array operations */ - Instruct(VECTLENGTH): - accu = Val_long(Wosize_val(accu)); + Instruct(VECTLENGTH): { + mlsize_t size = Wosize_val(accu); + if (Tag_val(accu) == Double_array_tag) size = size / Double_wosize; + accu = Val_long(size); Next; + } Instruct(GETVECTITEM): accu = Field(accu, Long_val(sp[0])); sp += 1; diff --git a/byterun/reverse.h b/byterun/reverse.h index 7d112a124..899734004 100644 --- a/byterun/reverse.h +++ b/byterun/reverse.h @@ -11,7 +11,7 @@ /* $Id$ */ -/* Swap byte-order in 32-bit integers and in words */ +/* Swap byte-order in 32-bit integers and in 64-bit floats */ #ifndef _reverse_ #define _reverse_ @@ -28,7 +28,7 @@ _p[2] = _a; \ } -#define Reverse_int64(d) { \ +#define Reverse_double(d) { \ char * _p; \ int _a; \ _p = (char *) (d); \ @@ -46,7 +46,4 @@ _p[4] = _a; \ } -#define Reverse_double Reverse_int64 - - #endif /* _reverse_ */ |