1: # 20 "./lpsrc/flx_enstack.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_mbind
10: open Flx_srcref
11: open List
12: open Flx_unify
13: open Flx_treg
14: open Flx_generic
15: open Flx_maps
16: open Flx_exceptions
17:
18: (* first approximation: we can stack functions that have no
19: function or procedure children AND no variables: later
20: we will check the return type, for now just check
21: the code generator works
22: *)
23:
24: (* return true if exes contain BEXPR_parse expression *)
25: let check_parser_calls exes : bool =
26: let cp = function
27: | `BEXPR_parse _,_ -> raise Not_found
28: | _ -> ()
29: in
30: let cpe e = iter_tbexpr ignore cp ignore e in
31: try
32: iter (iter_bexe ignore cpe ignore ignore ignore) exes;
33: false
34: with Not_found -> true
35:
36: (* The Pure property is a bit weird. We consider a function pure
37: if it doesn't need a stack frame, and can make do with
38: individual variables. This allows the function to be modelled
39: with an actual C function.
40:
41: A pure function must be top level and cannot have any
42: child functions. This means it depends only on its parameters
43: and globals -- globals are allowed because we pass the thread
44: frame pointer in, even to C functions.
45:
46: We assume a non-toplevel function is a child of some other
47: function for a reason -- to access that functions environment.
48: Still .. we could pass the display in, just as we pass the
49: thread frame pointer.
50:
51: What we really cannot allow is a child function, since we
52: cannot pass IT our frame pointer, since we don't have one.
53:
54: Because of this weird notion, we can also mark procedures
55: pure under the same conditions, and implement them as
56: C functions as well.
57:
58: Note neither a function nor procedure can be pure unless
59: it is also stackable, and the C function model can't be used
60: for either if a heap closure is formed.
61: *)
62: let rec is_pure syms (child_map, bbdfns) i =
63: let children = try Hashtbl.find child_map i with Not_found -> [] in
64: let id,parent,sr,entry = Hashtbl.find bbdfns i in
65: (*
66: print_endline ("Checking purity of " ^ id ^ "<" ^ si i ^ ">");
67: *)
68: match entry with
69: | `BBDCL_var _
70: | `BBDCL_ref _
71: | `BBDCL_val _
72: | `BBDCL_tmp _
73: | `BBDCL_const_ctor _
74: | `BBDCL_nonconst_ctor _
75: | `BBDCL_callback _
76: | `BBDCL_insert _
77: | `BBDCL_struct _
78: | `BBDCL_cstruct _
79: | `BBDCL_union _
80: | `BBDCL_abs _
81: | `BBDCL_newtype _
82: | `BBDCL_const _
83: | `BBDCL_typeclass _
84: | `BBDCL_instance _
85: ->
86: (*
87: print_endline (id ^ " is intrinsically pure");
88: *)
89: true
90:
91: (* not sure if this is the right place for this check .. *)
92: | `BBDCL_fun (_,_,_,_,ct,_,_)
93: | `BBDCL_proc (_,_,_,ct,_) ->
94: ct <> `Virtual
95:
96: | `BBDCL_cclass _ (* not sure FIXME .. *)
97: | `BBDCL_class _ (* not sure FIXME .. *)
98: | `BBDCL_glr _
99: | `BBDCL_reglex _
100: | `BBDCL_regmatch _
101: ->
102: (*
103: print_endline (id ^ " is intrinsically Not pure");
104: *)
105: false
106:
107: | `BBDCL_procedure (_,_,_,exes) (* ALLOWED NOW *)
108: | `BBDCL_function (_,_,_,_,exes) ->
109: match parent with
110: | Some _ ->
111: (*
112: print_endline (id ^ " is parented so Not pure");
113: *)
114: false
115:
116: | None ->
117: try
118: iter (fun kid ->
119: if not (is_pure syms (child_map, bbdfns) kid)
120: then begin
121: (*
122: print_endline ("Child " ^ si kid ^ " of " ^ id ^ " is not pure");
123: *)
124: raise Not_found
125: end
126: (*
127: else begin
128: print_endline ("Child " ^ si kid ^ " of " ^ id ^ " is pure");
129: end
130: *)
131: )
132: children
133: ;
134: (*
135: print_endline (id ^ " is checked pure, checking for parser calls ..");
136: *)
137: let pure = not (check_parser_calls exes) in
138: (*
139: if pure then
140: print_endline (id ^ " is Pure")
141: else
142: print_endline (id ^ " calls a parser, NOT Pure")
143: ;
144: *)
145: pure
146:
147: with
148: | Not_found ->
149: (*
150: print_endline (id ^ " is checked Not pure");
151: *)
152: false
153:
154:
155: exception Found
156:
157: (* A function is stackable provided it doesn't return
158: a pointer to itself. There are only two ways this
159: can happen: the function returns the address of
160: a variable, or, it returns the closure of a child.
161:
162: We will check the return type for pointer or
163: function types. If its a function, there
164: has to be at least one child to grab our this
165: pointer in its display. If its a pointer,
166: there has to be either a variable, or any
167: non-stackable child function, or any child
168: procedure -- note that the pointer might address
169: a variable in a child function or procedure,
170: however it can't 'get out' of a function except
171: by it being returned.
172:
173: Proposition: type variables cannot carry either
174: pointers to a variable or a child function closure.
175:
176: Reason: type variables are all universally quantified
177: and unconstrained. We would have v1 = &v2 for the pointer
178: case, contrary to the current lack of constraints.
179: Smly for functions. So we'll just ignore type variables.
180:
181: NOTE: a stacked frame is perfectly viable as a display
182: entry -- a heaped child can still refer to a stacked
183: parent frame: of course the child must not both persist
184: after the frame dies and also refer to that frame.
185:
186: This means the display, not just the caller, must be nulled
187: out of a routine when it loses control finally. Hmmm .. not
188: sure I'm doing that. That means only *explicit* Felix pointers
189: in the child refering to the parent frame can hold onto
190: the frame. In this case the parent must be heaped if the child
191: is, since the parent stacked frame is lost when control is lost.
192: *)
193:
194: let has_var bbdfns children =
195: try
196: iter
197: (fun i ->
198: let id,parent,sr,entry = Hashtbl.find bbdfns i in
199: match entry with
200: | `BBDCL_var _ -> raise Found
201: | _ -> ()
202: )
203: children
204: ;
205: true
206: with Found -> false
207:
208: let has_fun bbdfns children =
209: try
210: iter
211: (fun i ->
212: let id,parent,sr,entry = Hashtbl.find bbdfns i in
213: match entry with
214: | `BBDCL_procedure _
215: | `BBDCL_function _ -> raise Found
216: | _ -> ()
217: )
218: children
219: ;
220: true
221: with Found -> false
222:
223:
224: (* NOTE: this won't work for abstracted types like unions
225: or structs ..
226: *)
227: exception Unsafe
228:
229: let has_ptr_fn cache syms bbdfns children e =
230: let rec aux e =
231: let check_components vs ts tlist =
232: let varmap = mk_varmap vs ts in
233: begin try
234: iter
235: (fun t ->
236: let t = varmap_subst varmap t in
237: aux t
238: )
239: tlist;
240: Hashtbl.replace cache e `Safe
241: with Unsafe ->
242: Hashtbl.replace cache e `Unsafe;
243: raise Unsafe
244: end
245: in
246: try match Hashtbl.find cache e with
247: | `Recurse -> ()
248: | `Unsafe -> raise Unsafe
249: | `Safe -> ()
250: with Not_found ->
251: Hashtbl.add cache e `Recurse;
252: match e with
253: | `BTYP_function _ ->
254: (* if has_fun bbdfns children then *)
255: Hashtbl.replace cache e `Unsafe;
256: raise Unsafe
257:
258: | `BTYP_pointer _ ->
259: (* encode the more lenient condition here!! *)
260: Hashtbl.replace cache e `Unsafe;
261: raise Unsafe
262:
263: | `BTYP_inst (i,ts) ->
264: let id,parent,sr,entry = Hashtbl.find bbdfns i in
265: begin match entry with
266: | `BBDCL_newtype _ -> () (* FIXME *)
267: | `BBDCL_abs _ -> ()
268: | `BBDCL_union (vs,cs)->
269: check_components vs ts (map (fun (_,_,t)->t) cs)
270:
271: | `BBDCL_struct (vs,cs)
272: | `BBDCL_cstruct (vs,cs) ->
273: check_components vs ts (map snd cs)
274:
275: | `BBDCL_class _ ->
276: Hashtbl.replace cache e `Unsafe;
277: raise Unsafe
278:
279: | `BBDCL_cclass (vs,cs) ->
280: ()
281: (* nope, it isn't a use *)
282: (*
283: let tlist = map (function
284: | `BMemberVal (_,t)
285: | `BMemberVar (_,t)
286: | `BMemberFun (_,_,t)
287: | `BMemberProc (_,_,t)
288: | `BMemberCtor (_,t) -> t
289: ) cs
290: in
291: check_components vs ts tlist
292: *)
293:
294: | _ -> assert false
295: end
296: | x ->
297: try
298: iter_btype aux x;
299: Hashtbl.replace cache e `Safe
300: with Unsafe ->
301: Hashtbl.replace cache e `Unsafe;
302: raise Unsafe
303:
304: in try aux e; false with Unsafe -> true
305:
306: let can_stack_func cache syms (child_map,bbdfns) i =
307: let children = try Hashtbl.find child_map i with Not_found -> [] in
308: let id,parent,sr,entry = Hashtbl.find bbdfns i in
309: match entry with
310: | `BBDCL_function (_,_,_,ret,_) ->
311: not (has_ptr_fn cache syms bbdfns children ret)
312:
313: | `BBDCL_nonconst_ctor _
314: | `BBDCL_fun _
315: | `BBDCL_callback _
316: | `BBDCL_struct _
317: | `BBDCL_cstruct _
318: | `BBDCL_regmatch _
319: | `BBDCL_reglex _
320: -> false (* hack *)
321: | _ -> failwith ("Unexpected non-function " ^ id)
322:
323: let rec can_stack_proc cache syms (child_map,bbdfns) label_map label_usage i recstop =
324: let children = try Hashtbl.find child_map i with Not_found -> [] in
325: let id,parent,sr,entry = Hashtbl.find bbdfns i in
326: (*
327: print_endline ("Stackability Checking procedure " ^ id);
328: *)
329: match entry with
330: | `BBDCL_procedure (_,_,_,exes) ->
331: let labels = Hashtbl.find label_map i in
332: begin try iter (fun exe ->
333: (*
334: print_endline (string_of_bexe syms.dfns 0 exe);
335: *)
336: match exe with
337:
338: | `BEXE_axiom_check _ -> assert false
339: | `BEXE_svc _ -> raise Not_found
340: | `BEXE_call (_,(`BEXPR_closure (j,_),_),_)
341: | `BEXE_call_direct (_,j,_,_)
342: | `BEXE_call_method_direct (_,_,j,_,_)
343: | `BEXE_apply_ctor (_,_,_,_,j,_)
344:
345: (* this case needed for virtuals/typeclasses .. *)
346: | `BEXE_call_prim (_,j,_,_)
347: ->
348: if not (check_stackable_proc cache syms (child_map,bbdfns) label_map label_usage j (i::recstop))
349: then begin
350: (*
351: print_endline (id ^ " calls unstackable proc " ^ si j);
352: *)
353: raise Not_found
354: end
355:
356: (* assignments to a local variable are safe *)
357: | `BEXE_init (_,j,_)
358: | `BEXE_assign (_,(`BEXPR_name (j,_),_),_)
359: when mem j children -> ()
360:
361: | `BEXE_init (sr,_,(_,t))
362: | `BEXE_assign (sr,(_,t),_)
363: when not (has_ptr_fn cache syms bbdfns children t) -> ()
364:
365: | `BEXE_init _
366: | `BEXE_assign _ ->
367: (*
368: print_endline (id ^ " does foreign init/assignment");
369: *)
370: raise Not_found
371:
372: | `BEXE_call _
373: ->
374: (*
375: print_endline (id ^ " does nasty call");
376: *)
377: raise Not_found
378: | `BEXE_jump _
379: | `BEXE_jump_direct _
380: ->
381: (*
382: print_endline (id ^ " does jump");
383: *)
384: raise Not_found
385: | `BEXE_loop _
386: ->
387: (*
388: print_endline (id ^ " has loop?");
389: *)
390: raise Not_found
391:
392: | `BEXE_label (_,s) ->
393: let lno = Hashtbl.find labels s in
394: let lkind = Hashtbl.find label_usage lno in
395: if lkind = `Far then raise Not_found
396:
397: | `BEXE_yield _
398: | `BEXE_fun_return _ -> assert false
399:
400: (* Assume these are safe .. ? *)
401: | `BEXE_code _
402: | `BEXE_nonreturn_code _
403:
404: | `BEXE_apply_ctor_stack _
405: | `BEXE_call_stack _ (* cool *)
406: | `BEXE_call_method_stack _
407: | `BEXE_halt _
408: | `BEXE_comment _
409: | `BEXE_goto _
410: | `BEXE_ifgoto _
411: | `BEXE_ifnotgoto _
412: | `BEXE_assert _
413: | `BEXE_assert2 _
414: | `BEXE_begin
415: | `BEXE_end
416: | `BEXE_nop _
417: | `BEXE_proc_return _
418: -> ()
419: )
420: exes;
421: (*
422: print_endline (id ^ " is stackable");
423: *)
424: true
425: with Not_found ->
426: (*
427: print_endline (id ^ " cannot be stacked ..");
428: *)
429: false
430: end
431:
432: | _ -> assert false
433:
434: and check_stackable_proc cache syms (child_map,bbdfns) label_map label_usage i recstop =
435: if mem i recstop then true else
436: let id,parent,sr,entry = Hashtbl.find bbdfns i in
437: match entry with
438: | `BBDCL_callback _ -> false (* not sure if this is right .. *)
439: | `BBDCL_proc (_,_,_,ct,_) -> ct <> `Virtual
440: | `BBDCL_procedure (props,vs,p,exes) ->
441: if mem `Stackable props then true
442: else if mem `Unstackable props then false
443: else if can_stack_proc cache syms (child_map,bbdfns) label_map label_usage i recstop
444: then begin
445: (*
446: print_endline ("MARKING PROCEDURE " ^ id ^ " stackable!");
447: *)
448: let props = `Stackable :: props in
449: let props =
450: if is_pure syms (child_map,bbdfns) i then `Pure :: props else props
451: in
452: let entry : bbdcl_t = `BBDCL_procedure (props,vs,p,exes) in
453: Hashtbl.replace bbdfns i (id,parent,sr,entry);
454: true
455: end
456: else begin
457: let entry : bbdcl_t = `BBDCL_procedure (`Unstackable :: props,vs,p,exes) in
458: Hashtbl.replace bbdfns i (id,parent,sr,entry);
459: false
460: end
461: | _ -> failwith ("Unexpected non-procedure " ^ id)
462: (*
463: assert false
464: *)
465:
466: let ident x = x
467: let tident t = t
468:
469: (* this routine NORMALISES applications to one of the forms:
470: apply_stack -- apply on the stack
471: apply_direct -- direct application
472: apply_prim -- apply primitive
473: apply_struct -- apply struct, cstruct, or nonconst variant type constructor
474: apply -- general apply
475: *)
476: let rec enstack_applies cache syms (child_map, bbdfns) x =
477: let ea e = enstack_applies cache syms (child_map, bbdfns) e in
478: match map_tbexpr ident ea tident x with
479: | (
480: `BEXPR_apply ((`BEXPR_closure(i,ts),_),b),t
481: | `BEXPR_apply_direct (i,ts,b),t
482: ) as x ->
483: begin
484: let _,_,_,entry = Hashtbl.find bbdfns i in
485: match entry with
486: | `BBDCL_function (props,_,_,_,_) ->
487: if mem `Stackable props
488: then `BEXPR_apply_stack (i,ts,b),t
489: else `BEXPR_apply_direct (i,ts,b),t
490: | `BBDCL_fun _
491: | `BBDCL_callback _ ->
492: `BEXPR_apply_prim(i,ts,b),t
493:
494: | `BBDCL_struct _
495: | `BBDCL_cstruct _
496: | `BBDCL_nonconst_ctor _ ->
497: `BEXPR_apply_struct(i,ts,b),t
498: | _ -> x
499: end
500: | (
501: `BEXPR_apply ((`BEXPR_method_closure (obj,meth,ts),_),b),t
502: | `BEXPR_apply_method_direct (obj,meth,ts,b),t
503: ) as x ->
504: begin
505: let _,_,_,entry = Hashtbl.find bbdfns meth in
506: match entry with
507: | `BBDCL_function (props,_,_,_,_) ->
508: if mem `Stackable props
509: then `BEXPR_apply_method_stack (obj,meth,ts,b),t
510: else `BEXPR_apply_method_direct (obj,meth,ts,b),t
511: | _ -> x
512: end
513: | x -> x
514:
515: let mark_stackable cache syms (child_map,bbdfns) label_map label_usage =
516: Hashtbl.iter
517: (fun i (id,parent,sr,entry) ->
518: match entry with
519: | `BBDCL_function (props,vs,p,ret,exes) ->
520: let props: property_t list ref = ref props in
521: if can_stack_func cache syms (child_map,bbdfns) i then
522: begin
523: props := `Stackable :: !props;
524: if is_pure syms (child_map,bbdfns) i then
525: begin
526: (*
527: print_endline ("Function " ^ id ^ "<" ^ si i ^ "> is PURE");
528: *)
529: props := `Pure :: !props;
530: end
531: (*
532: else
533: print_endline ("Stackable Function " ^ id ^ "<" ^ si i ^ "> is NOT PURE")
534: *)
535: end
536: (*
537: else print_endline ("Function " ^ id ^ "<" ^ si i ^ "> is NOT STACKABLE")
538: *)
539: ;
540: let props : property_t list = !props in
541: let entry : bbdcl_t = `BBDCL_function (props,vs,p,ret,exes) in
542: Hashtbl.replace bbdfns i (id,parent,sr,entry)
543:
544: | `BBDCL_procedure (props,vs,p,exes) ->
545: if mem `Stackable props or mem `Unstackable props then ()
546: else ignore(check_stackable_proc cache syms (child_map,bbdfns) label_map label_usage i [])
547: | _ -> ()
548: )
549: bbdfns
550:
551: let enstack_calls cache syms (child_map,bbdfns) self exes =
552: let ea e = enstack_applies cache syms (child_map, bbdfns) e in
553: let id x = x in
554: let exes =
555: map (
556: fun exe -> let exe = match exe with
557: | `BEXE_call (sr,(`BEXPR_closure (i,ts),_),a)
558: | `BEXE_call_direct (sr,i,ts,a) ->
559: let id,parent,sr,entry = Hashtbl.find bbdfns i in
560: begin match entry with
561: | `BBDCL_procedure (props,vs,p,exes) ->
562: if mem `Stackable props then
563: begin
564: if not (mem `Stack_closure props) then
565: Hashtbl.replace bbdfns i (id,parent,sr,`BBDCL_procedure (`Stack_closure::props,vs,p,exes))
566: ;
567: `BEXE_call_stack (sr,i,ts,a)
568: end
569: else
570: `BEXE_call_direct (sr,i,ts,a)
571:
572: | `BBDCL_proc _ -> `BEXE_call_prim (sr,i,ts,a)
573:
574: (* seems to work at the moment *)
575: | `BBDCL_callback _ -> `BEXE_call_direct (sr,i,ts,a)
576:
577: | _ -> syserr sr ("Call to non-procedure " ^ id ^ "<" ^ si i ^ ">")
578: end
579:
580: | `BEXE_call_method_direct (sr,obj,i,ts,a) ->
581: let id,parent,sr,entry = Hashtbl.find bbdfns i in
582: begin match entry with
583: | `BBDCL_procedure (props,vs,p,exes) ->
584: if mem `Stackable props then
585: begin
586: if not (mem `Stack_closure props) then
587: Hashtbl.replace bbdfns i (id,parent,sr,`BBDCL_procedure (`Stack_closure::props,vs,p,exes))
588: ;
589: (*
590: print_endline "CALL_METHOD_STACK";
591: *)
592: `BEXE_call_method_stack (sr,obj,i,ts,a)
593: end
594: else
595: `BEXE_call_method_direct (sr,obj,i,ts,a)
596:
597: | _ -> assert false
598: end
599:
600: | `BEXE_apply_ctor (sr,v,obj,ts,meth,a) ->
601: let id,parent,sr,entry = Hashtbl.find bbdfns meth in
602: begin match entry with
603: | `BBDCL_procedure (props,vs,p,exes) ->
604: if mem `Stackable props then
605: begin
606: if not (mem `Stack_closure props) then
607: Hashtbl.replace bbdfns meth (id,parent,sr,`BBDCL_procedure (`Stack_closure::props,vs,p,exes))
608: ;
609: (*
610: print_endline "APPLY_CTOR_STACK";
611: *)
612: `BEXE_apply_ctor_stack (sr,v,obj,ts,meth,a)
613: end
614: else
615: `BEXE_apply_ctor (sr,v,obj,ts,meth,a)
616:
617: | _ -> assert false
618: end
619:
620: | x -> x
621: in
622: map_bexe id ea id id id exe
623: )
624: exes
625: in
626: exes
627:
628: let make_stack_calls syms (child_map, (bbdfns: fully_bound_symbol_table_t)) label_map label_usage =
629: let cache = Hashtbl.create 97 in
630: let ea e = enstack_applies cache syms (child_map, bbdfns) e in
631: mark_stackable cache syms (child_map,bbdfns) label_map label_usage;
632: Hashtbl.iter
633: (fun i (id,parent,sr,entry) -> match entry with
634: | `BBDCL_procedure (props,vs,p,exes) ->
635: let exes = enstack_calls cache syms (child_map,bbdfns) i exes in
636: let exes = Flx_cflow.final_tailcall_opt exes in
637: let id,parent,sr,entry = Hashtbl.find bbdfns i in
638: begin match entry with
639: | `BBDCL_procedure (props,vs,p,_) ->
640: Hashtbl.replace bbdfns i (id,parent,sr,`BBDCL_procedure (props,vs,p,exes))
641: | _ -> assert false
642: end
643:
644: | `BBDCL_function (props,vs,p,ret,exes) ->
645: let exes = enstack_calls cache syms (child_map,bbdfns) i exes in
646: let id,parent,sr,entry = Hashtbl.find bbdfns i in
647: begin match entry with
648: | `BBDCL_function (props,vs,p,ret,_) ->
649: Hashtbl.replace bbdfns i (id,parent,sr,`BBDCL_function (props,vs,p,ret,exes))
650: | _ -> assert false
651: end
652:
653: | `BBDCL_glr (props,vs,t,(p,exes)) ->
654: let exes = enstack_calls cache syms (child_map,bbdfns) i exes in
655: let id,parent,sr,entry = Hashtbl.find bbdfns i in
656: begin match entry with
657: | `BBDCL_glr (props,vs,t,(p,_)) ->
658: Hashtbl.replace bbdfns i (id,parent,sr,`BBDCL_glr (props,vs,t,(p,exes)))
659: | _ -> assert false
660: end
661:
662: | `BBDCL_regmatch (_,vs,p,t,(a,i,h,m)) ->
663: Hashtbl.iter
664: (fun k e -> Hashtbl.replace h k (ea e))
665: h
666:
667: | `BBDCL_reglex (_,vs,p,j,t,(a,i,h,m)) ->
668: Hashtbl.iter
669: (fun k e -> Hashtbl.replace h k (ea e))
670: h
671:
672: | _ -> ()
673: )
674: bbdfns
675: