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