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