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 118 - (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 : monnier 102 (*
34 : monnier 16 | notconst(_,_,CONty(_,[t,_])) =
35 :     (case (reduce t)
36 :     of CONty(RECORDtyc nil,_) => false
37 :     | _ => true)
38 : monnier 102 *)
39 : monnier 16 | notconst _ = true
40 :    
41 : league 78 (*
42 :     * fun show((sym,_,_)::syms, r::rs) =
43 :     * (print(Symbol.name sym); print ": ";
44 :     * PPBasics.ppRep r; print "\n"; show(syms,rs))
45 :     * | show _ = (print "\n")
46 :     *)
47 :    
48 : monnier 16 (* the first argument indicates whether this is a recursive datatypes *)
49 :     fun infer false ([(_, false, CONty(_,[ty,_]))]) =
50 :     (case (reduce ty)
51 : monnier 102 of (* (CONty(RECORDtyc nil, _)) => ([CONSTANT 0], CSIG (0,1))
52 :     | *) _ => ([UNTAGGED], CSIG(1,0)) (* [TRANSPARENT] *))
53 : monnier 16 (* The TRANSPARENT conrep is temporarily turned off;
54 :     it should be working very soon. Ask zsh. *)
55 :    
56 :     | infer _ cons =
57 :     let val multiple = (count notconst cons) > 1
58 :    
59 :     fun decide (ctag,vtag, (_,true,_)::rest, reps) =
60 :     if multiple andalso !Control.CG.boxedconstconreps
61 :     then decide(ctag, vtag+1, rest, (TAGGED vtag) :: reps)
62 :     else decide(ctag+1, vtag, rest, (CONSTANT ctag) :: reps)
63 :    
64 :     | decide (ctag,vtag, (_,false,CONty(_,[ty,_]))::rest, reps) =
65 :     (case (reduce ty, multiple)
66 : monnier 102 of (*
67 :     (CONty(RECORDtyc nil,_),_) =>
68 : league 78 decide(ctag+1, vtag, rest, (CONSTANT ctag) :: reps)
69 : monnier 102 | *)
70 :     (_, true) =>
71 : monnier 16 decide(ctag, vtag+1, rest, (TAGGED vtag) :: reps)
72 :     | (_, false) =>
73 :     decide(ctag, vtag+1, rest, (UNTAGGED :: reps)))
74 :     | decide (_, _, _::_, _) = err "unexpected conrep-decide"
75 :     | decide (ctag, vtag, [], reps) = (rev reps, CSIG(vtag,ctag))
76 :    
77 :     in decide(0, 0, cons, [])
78 :     end
79 :    
80 : league 78 (*** val infer = fn l => let val l' = infer l in show(l,l'); l' end ***)
81 : monnier 16
82 :     end (* local *)
83 :     end (* structure ConRep *)
84 :    
85 :    
86 :     (*
87 : monnier 118 * $Log$
88 : monnier 109 *
89 : monnier 16 *)

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