Annotation of /sml/trunk/src/compiler/FLINT/opt/optutils.sml

Parent Directory | Revision Log

---

Revision 184 - (view) (download)

1 :	monnier	163	(* copyright 1998 YALE FLINT PROJECT *)
2 :			(* monnier@cs.yale.edu *)
3 :
4 :			signature OPT_UTILS =
5 :			sig
6 :
7 :	monnier	184	datatype ('a,'b) either = A of 'a | B of 'b
8 :
9 :	monnier	163	(* takes the fk of a function and returns the fk of the wrapper
10 :			* along with the new fk of the actual body *)
11 :			val fk_wrap : FLINT.fkind * FLINT.lty list option ->
12 :			(FLINT.fkind * FLINT.fkind)
13 :
14 :			(* sometimes I get fed up rewriting the identity function *)
15 :			val id : 'a -> 'a
16 :
17 :			(* this is a known APL function, but I don't know its real name *)
18 :			val filter : bool list * 'a list -> 'a list
19 :			end
20 :
21 :			structure OptUtils :> OPT_UTILS =
22 :			struct
23 :			local structure F = FLINT
24 :			structure LK = LtyKernel
25 :			in
26 :	monnier	184	datatype ('a,'b) either = A of 'a | B of 'b
27 :
28 :	monnier	163	fun bug msg = ErrorMsg.impossible ("OptUtils: "^msg)
29 :
30 :	monnier	184	fun fk_wrap ({inline,known,isrec,cconv},rtys') =
31 :			let val cconv' =
32 :			case cconv
33 :			of F.CC_FUN(LK.FF_VAR(f1,f2)) => F.CC_FUN(LK.FF_VAR(true, f2))
34 :			| (F.CC_FCT | F.CC_FUN(LK.FF_FIXED)) => cconv
35 :			val isrec' = Option.map (fn ltys => (ltys, F.LK_UNKNOWN)) rtys'
36 :			in ({isrec=isrec, known=known, cconv=cconv, inline=F.IH_ALWAYS},
37 :			{isrec=isrec', known=true, cconv=cconv', inline=inline})
38 :	monnier	163	end
39 :
40 :			fun filter ([],[]) = []
41 :			| filter (true::fs,x::xs) = x::(filter(fs, xs))
42 :			| filter (false::fs,x::xs) = (filter(fs, xs))
43 :			| filter _ = bug "unmatched list length in filter"
44 :
45 :			fun id x = x
46 :
47 :			end
48 :			end

---

root@smlnj-gforge.cs.uchicago.edu	ViewVC Help
Powered by ViewVC 1.0.0