Annotation of /sml/trunk/src/compiler/Semant/basics/conrep.sml

Parent Directory | Revision Log

---

Revision 77 - (view) (download)

1 :	monnier	16	(* Copyright 1996 by AT&T Bell Laboratories *)
2 :			(* conrep.sml *)
3 :
4 :			signature CONREP =
5 :			sig
6 :
7 :			val infer : bool -> (Symbol.symbol * bool * Types.ty) list
8 :			-> (Access.conrep list * Access.consig)
9 :
10 :			end (* signature CONREP *)
11 :
12 :
13 :			structure ConRep : CONREP =
14 :			struct
15 :
16 :			local open Access Types
17 :			in
18 :
19 :			fun err s = ErrorMsg.impossible ("Conrep: "^s)
20 :
21 :			fun count predicate l =
22 :			let fun test (a::rest,acc) = test (rest,if predicate a then 1+acc else acc)
23 :			| test (nil,acc) = acc
24 :			in test (l,0)
25 :			end
26 :
27 :			fun reduce ty =
28 :			case TypesUtil.headReduceType ty
29 :			of POLYty{tyfun=TYFUN{body,...},...} => reduce body
30 :			| ty => ty
31 :
32 :			fun notconst(_,true,_) = false
33 :			| notconst(_,_,CONty(_,[t,_])) =
34 :			(case (reduce t)
35 :			of CONty(RECORDtyc nil,_) => false
36 :			| _ => true)
37 :			| notconst _ = true
38 :
39 :			(* the first argument indicates whether this is a recursive datatypes *)
40 :			fun infer false ([(_, false, CONty(_,[ty,_]))]) =
41 :			(case (reduce ty)
42 :			of (CONty(RECORDtyc nil, _)) => ([CONSTANT 0], CSIG (0,1))
43 :			| _ => ([UNTAGGED], CSIG(1,0)) (* [TRANSPARENT] *))
44 :			(* The TRANSPARENT conrep is temporarily turned off;
45 :			it should be working very soon. Ask zsh. *)
46 :
47 :			| infer _ cons =
48 :			let val multiple = (count notconst cons) > 1
49 :
50 :			fun decide (ctag,vtag, (_,true,_)::rest, reps) =
51 :			if multiple andalso !Control.CG.boxedconstconreps
52 :			then decide(ctag, vtag+1, rest, (TAGGED vtag) :: reps)
53 :			else decide(ctag+1, vtag, rest, (CONSTANT ctag) :: reps)
54 :
55 :			| decide (ctag,vtag, (_,false,CONty(_,[ty,_]))::rest, reps) =
56 :			(case (reduce ty, multiple)
57 :			of (CONty(RECORDtyc nil,_),_) =>
58 :	league	77	decide(ctag+1, vtag, rest, (CONSTANT ctag) :: reps)
59 :	monnier	16	| (_, true) =>
60 :			decide(ctag, vtag+1, rest, (TAGGED vtag) :: reps)
61 :			| (_, false) =>
62 :			decide(ctag, vtag+1, rest, (UNTAGGED :: reps)))
63 :			| decide (_, _, _::_, _) = err "unexpected conrep-decide"
64 :			| decide (ctag, vtag, [], reps) = (rev reps, CSIG(vtag,ctag))
65 :
66 :			in decide(0, 0, cons, [])
67 :			end
68 :
69 :	league	77	(** rebind infer for debugging purpose **)
70 :			local
71 :			val pps = PrettyPrint.mk_ppstream
72 :			{consumer=TextIO.print,
73 :			linewidth=80,
74 :			flush = fn() => TextIO.flushOut TextIO.stdOut}
75 :	monnier	16
76 :	league	77	fun show((sym,_,_)::syms, r::rs) =
77 :			(print(Symbol.name sym); print ": ";
78 :			PPVal.ppRep pps r; print "\n"; show(syms,rs))
79 :			| show _ = (print "\n")
80 :
81 :			fun dbg flag cons =
82 :			let val result = infer flag cons
83 :			in
84 :			if !Control.CG.etdebugging then
85 :			show(cons, #1 result)
86 :			else ();
87 :			result
88 :			end
89 :			in
90 :			val infer = dbg
91 :			end (* local debugging *)
92 :
93 :
94 :	monnier	16	end (* local *)
95 :	league	77
96 :	monnier	16	end (* structure ConRep *)
97 :
98 :
99 :			(*
100 :			* $Log: conrep.sml,v $
101 :			* Revision 1.1.1.1 1997/01/14 01:38:09 george
102 :			* Version 109.24
103 :			*
104 :			*)

---

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