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

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