Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/Semant/basics/conrep.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log 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