1: # 21 "./lpsrc/flx_bexe.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_types
5: open Flx_print
6: open Flx_mtypes1
7: open Flx_mtypes2
8: open Flx_typing
9: open Flx_lookup
10: open Flx_mbind
11: open Flx_srcref
12: open Flx_unify
13: open Flx_exceptions
14: open List
15:
16: let rec check_if_parent syms child parent =
17: if child = parent then true
18: else
19: match Hashtbl.find syms.dfns child with
20: | {parent=Some parent} -> check_if_parent syms child parent
21: | {parent=None} -> false
22:
23: let cal_call syms sr ((p,pt) as tbe1) ((_,argt) as tbe2) =
24: match unfold syms.dfns pt with
25: | `BTYP_lvalue (`BTYP_cfunction (t, `BTYP_void))
26: | `BTYP_cfunction (t, `BTYP_void)
27: | `BTYP_lvalue (`BTYP_function (t, `BTYP_void))
28: | `BTYP_function (t, `BTYP_void) ->
29: if type_match syms.dfns t argt
30: then
31: (
32: match p with
33: | `BEXPR_closure (i,ts) ->
34: begin match Hashtbl.find syms.dfns i with
35: | {symdef=`SYMDEF_fun _ }
36: | {symdef=`SYMDEF_callback _ }
37: ->
38: `BEXE_call_prim (sr,i,ts,tbe2)
39:
40: | {symdef=`SYMDEF_function _} ->
41: `BEXE_call_direct (sr,i,ts,tbe2)
42:
43: | _ -> assert false
44: end
45: | _ ->
46: `BEXE_call (sr,(p,lower pt), tbe2)
47: )
48: else
49: clierr sr
50: (
51: "[cal_call] Procedure " ^
52: sbe syms.dfns tbe1 ^
53: "\nof type " ^
54: sbt syms.dfns pt ^
55: "\napplied to argument " ^
56: sbe syms.dfns tbe2 ^
57: "\n of type " ^
58: sbt syms.dfns argt ^
59: "\nwhich doesn't agree with parameter type\n" ^
60: sbt syms.dfns t
61: )
62:
63: | _ ->
64: clierr sr ("[cal_call] call non procedure, "^
65: sbe syms.dfns (p,pt)
66: ^"\ntype=" ^ sbt syms.dfns pt)
67:
68: let cal_loop syms sr ((p,pt) as tbe1) ((_,argt) as tbe2) this =
69: match unfold syms.dfns pt with
70: | `BTYP_function (t, `BTYP_void) ->
71: if t = argt
72: then
73: match p with
74: | `BEXPR_closure (i,ts) ->
75: if check_if_parent syms i this
76: then
77: `BEXE_call_direct (sr,i, ts, tbe2)
78: else
79: clierr sr
80: "[cal_loop] Loop target must be self or parent"
81:
82: | _ ->
83: clierr sr (
84: "[cal_loop] Expected procedure closure, got "^
85: string_of_bound_expression syms.dfns (p,pt)
86: )
87: else
88: clierr sr
89: (
90: "[cal_loop] Procedure " ^
91: sbe syms.dfns tbe1 ^
92: "\nof type " ^
93: sbt syms.dfns pt ^
94: "\napplied to argument " ^
95: sbe syms.dfns tbe2 ^
96: "\n of type " ^
97: sbt syms.dfns argt ^
98: "\nwhich doesn't agree with parameter type\n" ^
99: sbt syms.dfns t
100: )
101:
102: | _ ->
103: clierr sr ("[cal_loop] loop to non procedure, "^
104: string_of_bound_expression syms.dfns (p,pt)
105: ^"\ntype=" ^ string_of_btypecode syms.dfns pt)
106:
107: exception Found of int
108:
109: let print_vs vs =
110: catmap "," (fun (s,i) -> s ^ "->" ^ si i) vs
111:
112: let bind_exes syms env sr exes ret_type id index parent_vs =
113: (*
114: print_endline ("bind_exes.. env depth="^ string_of_int (List.length env));
115: print_endline "Dumping Source Executables";
116: print_endline "--------------------------";
117: let soe e = Flx_print.string_of_expr e in
118: List.iter
119: (fun (_,x) -> print_endline (string_of_exe 1 x))
120: exes
121: ;
122: print_endline ""
123: ;
124:
125: print_endline "Binding Executables";
126: print_endline "-------------------";
127: *)
128:
129: (* a type variable in executable code just has to be of kind TYPE *)
130: let parent_ts = map (fun (s,i) -> `BTYP_var (i,`BTYP_type)) parent_vs in
131: let ret_type = ref ret_type in
132: let be e : tbexpr_t = bind_expression syms env e in
133: let lun sr n = lookup_name_in_env syms env sr n in
134: let luqn n = lookup_qn_in_env syms env n in
135: let bt sr t : btypecode_t = bind_type syms env sr t in
136: let return_count = ref 0 in
137: let reachable = ref true in
138: let proc_return_count = ref 0 in
139:
140: let bound_exes : bexe_t list ref = ref [] in
141: let tack x = bound_exes := x :: !bound_exes in
142: let rec bind_exe (sr,x) =
143: (*
144: print_endline ("EXE="^string_of_exe 1 x);
145: *)
146: if not !reachable then
147: begin
148: match x with
149: | `EXE_label _ -> ()
150: | `EXE_comment _ -> ()
151: | `EXE_nop _ -> ()
152: | _ -> print_endline
153: (
154: "WARNING: Unreachable code in "^id^": " ^
155: string_of_exe 1 x ^ " in\n" ^
156: short_string_of_src sr
157: );
158: end
159: ;
160: match x with
161: | `EXE_comment s -> tack (`BEXE_comment (sr,s))
162: | `EXE_label s -> reachable := true; tack (`BEXE_label (sr,s))
163: | `EXE_goto s -> reachable := false; tack (`BEXE_goto (sr,s))
164:
165: | `EXE_ifgoto (e,s) ->
166: let e',t = be e in
167: if lstrip syms.dfns t = flx_bbool
168: then tack (`BEXE_ifgoto (sr,(e',t), s))
169: else
170: clierr (src_of_expr e)
171: (
172: "[bind_exes:ifgoto] Conditional requires bool argument, got " ^
173: string_of_btypecode syms.dfns t
174: )
175:
176: | `EXE_ifnotgoto (e,s) ->
177: let e',t = be e in
178: if lstrip syms.dfns t = flx_bbool
179: then tack (`BEXE_ifnotgoto (sr,(e',t), s))
180: else
181: clierr (src_of_expr e)
182: (
183: "[bind_exes:ifnotgoto] Conditional requires bool argument, got " ^
184: string_of_btypecode syms.dfns t ^ " in\n" ^
185: short_string_of_src sr
186: )
187:
188: | `EXE_loop (n,e2) ->
189: let be2,t2 = be e2 in
190: let tbe1 =
191: lookup_qn_with_sig
192: syms
193: sr sr
194: env
195: (`AST_name(sr,n,[]) : qualified_name_t)
196: [t2]
197: in
198: (* reverse order .. *)
199: tack (`BEXE_proc_return sr);
200: (* note cal_loop actually generates a call .. *)
201: tack (cal_loop syms sr tbe1 (be2,t2) index)
202:
203: | `EXE_jump (a,b) ->
204: incr proc_return_count;
205: bind_exe (sr,`EXE_call (a,b));
206: bind_exe (sr,`EXE_proc_return)
207:
208: | `EXE_call (`AST_name (_,"axiom_check",[]), e2) ->
209: tack (`BEXE_axiom_check(sr,be e2))
210:
211: | `EXE_call (#suffixed_name_t as sn, e2) -> (* OVERLOADING *)
212: let sr = src_of_expr sn in
213: let be2,t2 = be e2 in
214: let (be1,t1) as tbe1 =
215: match sn with
216: | #qualified_name_t as qn ->
217: lookup_qn_with_sig
218: syms
219: sr sr
220: env
221: qn [t2]
222: | _ -> be sn
223: in
224: tack (cal_call syms sr tbe1 (be2,t2))
225:
226: | `EXE_apply_ctor (vname, clsname, arg) ->
227: let (e2,t2) as barg = be arg in
228: let var_idx =
229: let varname = `AST_name (sr,vname,[]) in
230: match be varname with
231: | `BEXPR_name (i,[]),_ -> i
232: | _ -> clierr sr "Expected (nonpolymorphic) variable name to store object"
233: in
234: let cls = be clsname in
235: begin match cls with
236:
237: | `BEXPR_name (class_idx,ts),_ ->
238: begin
239: match
240: try Hashtbl.find syms.dfns class_idx
241: with Not_found ->
242: syserr sr ("[bexe][EXE_apply_ctor] Weird, can't find class index " ^ si class_idx)
243: with
244: | {id=name;pubmap=pubmap;symdef=`SYMDEF_class} ->
245: (*
246: print_endline ("Found a class "^name^", look for constructor with hacked name _ctor_"^name);
247: *)
248: let entries = lookup_name_in_htab pubmap ("_ctor_" ^ name) in
249: begin match entries with
250: | None -> clierr sr "Unable to find any constructors for this class"
251: | Some (NonFunctionEntry _) -> syserr sr
252: "[EXE_apply_ctor: lookup_name_in_table_dirs_with_sig] Expected constructor to be a procedure"
253:
254: | Some (FunctionEntry fs) ->
255: (*
256: print_endline ("Ok, found "^si (length fs) ^"constructors for " ^ name);
257: *)
258: let ro =
259: resolve_overload
260: syms sr fs ("_ctor_" ^ name) [t2] [] (* constructors can't be polymorphic *)
261: in
262: match ro with
263: | Some (ctor_idx,t,mgu,ts') ->
264: (* The overload resolution is generic, but the application
265: is concrete. so ts' should be a list of type variables
266: corresponding to the class vs, and the mgu should
267: map these to the ts used to instantiate the class..??
268: *)
269: if length ts' <> length ts then
270: clierr sr ("[EXE_apply_ctor] Type subscript mismatch:\n" ^
271: "got type subscripts " ^ catmap "," (sbt syms.dfns) ts')
272: ;
273: tack (`BEXE_apply_ctor (sr,var_idx,class_idx,ts,ctor_idx, barg))
274: | None ->
275: clierr sr
276: (
277: "Unable to find matching constructor for class " ^ name ^
278: "<" ^ si class_idx ^ ">[" ^
279: catmap "," (sbt syms.dfns) ts ^ "](" ^
280: sbt syms.dfns t2 ^ ")"
281: )
282: end
283: | _ -> clierr sr "Argument of new must be a class"
284: end
285: | `BEXPR_closure (i,ts),_ ->
286: clierr sr ("Class constructor must name class, and we got a closure (which is right but unexpected ..)")
287:
288: | _ ->
289: clierr sr ("Class constructor must name class, got " ^ sbe syms.dfns cls)
290: end
291:
292: | `EXE_call (p,e) ->
293: let p',pt' = be p and e',et' = be e in
294: tack (cal_call syms sr (p', pt') (e', et'))
295:
296: | `EXE_svc s ->
297: begin match lun sr s with
298: | NonFunctionEntry (index) ->
299: let {symdef=entry; id=id} = Hashtbl.find syms.dfns index in
300: begin match entry with
301: | `SYMDEF_var _ -> ()
302: | `SYMDEF_val _ -> clierr sr ("Can't svc into value " ^ id)
303: | `SYMDEF_parameter _ -> clierr sr ("Can't svc into parameter value " ^ id)
304: | _ -> clierr sr ("[bexe] svc requires variable, got " ^ id)
305: end
306: ;
307: tack (`BEXE_svc (sr,index))
308:
309: | FunctionEntry _ -> failwith "Can't svc function!"
310: end
311:
312: | `EXE_proc_return ->
313: incr proc_return_count;
314: reachable := false;
315: if do_unify syms !ret_type `BTYP_void
316: then
317: begin
318: ret_type := varmap_subst syms.varmap !ret_type;
319: tack (`BEXE_proc_return sr)
320: end
321: else
322: clierr sr
323: (
324: "function " ^id^" has void return type"
325: )
326:
327: | `EXE_fun_return e ->
328: reachable := false;
329: incr return_count;
330: let e',t' = be e in
331: let t' = minimise syms.dfns t' in
332: if do_unify syms !ret_type t' then begin
333: ret_type := varmap_subst syms.varmap !ret_type;
334: tack (`BEXE_fun_return (sr,(e',lower t')))
335: end
336: else
337: clierr sr
338: (
339: "In " ^ string_of_exe 0 x ^ "\n" ^
340: "Wrong return type,\nexpected : " ^
341: string_of_btypecode syms.dfns !ret_type ^
342: "\nbut we got " ^
343: string_of_btypecode syms.dfns t'
344: )
345:
346: | `EXE_nop s -> tack (`BEXE_nop (sr,s))
347: | `EXE_code s -> tack (`BEXE_code (sr,s))
348: | `EXE_noreturn_code s ->
349: reachable := false;
350: tack (`BEXE_nonreturn_code (sr,s))
351:
352: | `EXE_assert e ->
353: let (x,t) as e' = be e in
354: if lstrip syms.dfns t = flx_bbool
355: then tack (`BEXE_assert (sr,e'))
356: else clierr sr
357: (
358: "assert requires bool argument, got " ^
359: string_of_btypecode syms.dfns t
360: )
361:
362: | `EXE_iinit ((s,index),e) ->
363: let e',rhst = be e in
364: let lhst = typeofindex_with_ts syms sr index parent_ts in
365: let rhst = minimise syms.dfns rhst in
366: let lhst = match lhst with |`BTYP_lvalue t -> t | t -> t in
367: if type_match syms.dfns lhst rhst
368: then tack (`BEXE_init (sr,index, (e',rhst)))
369: else clierr sr
370: (
371: "[bind_exe] LHS["^s^"<"^si index^">]:\n"^
372: string_of_btypecode syms.dfns lhst^
373: "\n of initialisation must have same type as RHS:\n"^
374: string_of_btypecode syms.dfns rhst^
375: "\nunfolded LHS = " ^ sbt syms.dfns (unfold syms.dfns lhst) ^
376: "\nenvironment type variables are " ^
377: print_vs parent_vs
378:
379: )
380:
381: | `EXE_init (s,e) ->
382: begin match lun sr s with
383: | FunctionEntry _ -> clierr sr "Can't init function constant"
384: | NonFunctionEntry (index) ->
385: let e',rhst = be e in
386: let lhst = typeofindex_with_ts syms sr index parent_ts in
387: let rhst = minimise syms.dfns rhst in
388: let lhst = match lhst with |`BTYP_lvalue t -> t | t -> t in
389: (*
390: print_endline ("Checking type match " ^ sbt syms.dfns lhst ^ " ?= " ^ sbt syms.dfns rhst);
391: *)
392: if type_match syms.dfns lhst rhst
393: then tack (`BEXE_init (sr,index, (e',rhst)))
394: else clierr sr
395: (
396: "[bind_exe] LHS["^s^"<"^si index^">]:\n"^
397: string_of_btypecode syms.dfns lhst^
398: "\n of initialisation must have same type as RHS:\n"^
399: string_of_btypecode syms.dfns rhst^
400: "\nunfolded LHS = " ^ sbt syms.dfns (unfold syms.dfns lhst) ^
401: "\nenvironment type variables are " ^
402: print_vs parent_vs
403:
404: )
405: end
406:
407: | `EXE_assign (l,r) ->
408: let (_,lt) as bel = be l in
409: begin match lt with
410: | `BTYP_lvalue _ ->
411: tack (`BEXE_assign (sr,bel, be r))
412: | _ -> clierr sr "LHS must be lvalue"
413: end
414:
415: (*
416: begin match bel with
417: | `BEXPR_name (index,_),_ ->
418: let {symdef=entry; id=id} = Hashtbl.find syms.dfns index in
419: begin match entry with
420: | `SYMDEF_var _ -> ()
421: | `SYMDEF_val _ -> clierr sr ("Can't assign into value " ^ id)
422: | `SYMDEF_parameter _ -> clierr sr ("Can't assign into parameter value " ^ id)
423: | _ -> clierr sr ("[bexe] assign requires variable, got " ^ id)
424: end
425: | `BEXPR_deref _,_ -> ()
426:
427: | `BEXPR_apply_prim (i,_,_),_ ->
428: let {symdef=entry; id=id; vs=vs} = Hashtbl.find syms.dfns i in
429: begin match entry with
430: | `SYMDEF_fun (_,t,_,_) ->
431: begin match t with
432: | `TYP_lvalue _ -> ()
433: | _ ->
434: print_endline
435: (
436: "WARNING: assign to application of primitive "^
437: id^
438: " not declared to return an lvalue"
439: )
440: end
441: | _ ->
442: failwith
443: (
444: "[bexe]Expected prim apply to apply a primitive fun, got: " ^
445: string_of_symdef entry id vs
446: )
447: end
448: | _ ->
449: print_endline ("Assign to non variable..(is it an lvalue?)" ^ sbe syms.dfns bel);
450: ()
451: end
452: ;
453: tack (`BEXE_assign (sr,bel, be r))
454: *)
455:
456:
457: in
458: List.iter bind_exe exes;
459: let bound_exes = List.rev !bound_exes in
460: (*
461: print_endline ""
462: ;
463: List.iter
464: (fun x -> print_endline (string_of_bexe syms.dfns 1 x))
465: bound_exes
466: ;
467: print_endline ""
468: ;
469: print_endline "BINDING COMPLETE"
470: ;
471: *)
472:
473: (* No function return statements found: it must be a procedure,
474: so unify void [just a comparison with void .. heh!]
475: *)
476: if !return_count = 0 then
477: begin
478: if do_unify syms !ret_type `BTYP_void
479: then
480: ret_type := varmap_subst syms.varmap !ret_type
481: else
482: clierr sr
483: (
484: "procedure " ^id^" has non-void return type"
485: )
486: end
487: ;
488:
489: begin match !ret_type with
490: | `BTYP_void ->
491: if
492: not !reachable &&
493: !proc_return_count = 0 &&
494: syms.compiler_options.print_flag
495: then print_endline
496: (
497: "WARNING: procedure " ^id^
498: " has no explicit return and doesn't drop thru end," ^
499: "\npossible infinite loop"
500: )
501: | _ ->
502: if !reachable then begin
503: (* this is now a hard error ..
504: functions must manifestly return. We have to be careful
505: generating code where the compiler cannot deduce
506: that a final branch cannot be taken .. the user,
507: however, is required to supply a dead code assertion
508: to prevent the error.
509: *)
510: clierr sr
511: (
512: "[bind_exes]: function "^id^" drops off end, missing return statement"
513: )
514: (*
515: ;
516: print_endline "[DEBUG] Instruction sequence is:";
517: iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) bound_exes
518: *)
519: end
520: end
521: ;
522: !ret_type,bound_exes
523:
524: