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

SCM Repository

[smlnj] Diff of /sml/trunk/compiler/FLINT/main/literals.sml
ViewVC logotype

Diff of /sml/trunk/compiler/FLINT/main/literals.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

sml/trunk/src/compiler/FLINT/main/literals.sml revision 251, Mon Apr 19 02:55:26 1999 UTC sml/trunk/compiler/FLINT/main/literals.sml revision 2162, Thu Nov 2 21:20:47 2006 UTC
# Line 17  Line 17 
17  structure W8V = Word8Vector  structure W8V = Word8Vector
18    
19  local structure LV = LambdaVar  local structure LV = LambdaVar
20          structure Intset = struct
21            type intset = IntRedBlackSet.set ref
22            fun new() = ref IntRedBlackSet.empty
23            fun add set i = set := IntRedBlackSet.add(!set, i)
24            fun mem set i =  IntRedBlackSet.member(!set, i)
25            fun rmv set i = set := IntRedBlackSet.delete(!set, i)
26          end
27        open CPS        open CPS
28  in  in
29    
# Line 184  Line 191 
191    
192  exception LitInfo  exception LitInfo
193    
194  datatype rlit = RLIT of string * int  datatype rlit = RLIT of string * word
195  fun toRlit s = RLIT(s, StrgHash.hashString s)  fun toRlit s = RLIT(s, HashString.hashString s)
196  fun fromRlit (RLIT(s, _)) = s  fun fromRlit (RLIT(s, _)) = s
197  fun rlitcmp (RLIT(s1,i1), RLIT(s2,i2)) =  fun rlitcmp (RLIT(s1,i1), RLIT(s2,i2)) =
198    if i1 < i2 then LESS    if i1 < i2 then LESS
199    else if i1 > i2 then GREATER else String.compare(s1, s2)    else if i1 > i2 then GREATER else String.compare(s1, s2)
200  structure RlitDict = BinaryDict(struct type ord_key = rlit  structure RlitDict = RedBlackMapFn(struct type ord_key = rlit
201                                         val cmpKey = rlitcmp                                          val compare = rlitcmp
202                                  end)                                  end)
203    
204  (* lifting all literals from a CPS program *)  (* lifting all literals from a CPS program *)
205  fun liftlits (body, root, offset) =  fun liftlits (body, root, offset) =
206    let (* the list of record, string, or real constants *)    let (* the list of record, string, or real constants *)
207        val m : info Intmap.intmap = Intmap.new(32, LitInfo)        val m : info IntHashTable.hash_table = IntHashTable.mkTable(32, LitInfo)
208        val freevars : lvar list ref = ref []        val freevars : lvar list ref = ref []
209        fun addv x = (freevars := (x :: (!freevars)))        fun addv x = (freevars := (x :: (!freevars)))
210    
# Line 207  Line 214 
214        val isUsed : lvar -> bool = Intset.mem refset        val isUsed : lvar -> bool = Intset.mem refset
215    
216        (* memoize the information on which corresponds to what *)        (* memoize the information on which corresponds to what *)
217        fun enter (v, i) = (Intmap.add m (v, i); addv v)        fun enter (v, i) = (IntHashTable.insert m (v, i); addv v)
218        fun const (VAR v) = ((Intmap.map m v; true) handle _ => false)        fun const (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
219          | const (INT _ | INT32 _ | REAL _ | STRING _) = true          | const (INT _ | INT32 _ | REAL _ | STRING _) = true
220          | const _ = bug "unexpected case in const"          | const _ = bug "unexpected case in const"
221    
222        fun cstlit (VAR v) = ((Intmap.map m v; true) handle _ => false)        fun cstlit (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
223          | cstlit (REAL _ | STRING _) = true          | cstlit (REAL _ | STRING _) = true
224          | cstlit _ = false          | cstlit _ = false
225    
226        (* register a string literal *)        (* register a string literal *)
227        local val strs : string list ref = ref []        local val strs : string list ref = ref []
228              val strsN : int ref = ref 0              val strsN : int ref = ref 0
229              val sdict = ref (RlitDict.mkDict())              val sdict = ref (RlitDict.empty)
230              val srtv = mkv()              val srtv = mkv()
231              val srtval = VAR srtv              val srtval = VAR srtv
232        in        in
# Line 228  Line 235 
235              val sd = !sdict              val sd = !sdict
236              val rlit = toRlit s              val rlit = toRlit s
237              val n =              val n =
238                (case RlitDict.peek(sd, rlit)                (case RlitDict.find(sd, rlit)
239                  of SOME k => k                  of SOME k => k
240                   | _ => let val _ = (strs := (s :: (!strs)))                   | _ => let val _ = (strs := (s :: (!strs)))
241                              val k = !strsN                              val k = !strsN
# Line 266  Line 273 
273        (** a special treatment of real constants *)        (** a special treatment of real constants *)
274        local val reals : string list ref = ref []        local val reals : string list ref = ref []
275              val realsN : int ref = ref 0              val realsN : int ref = ref 0
276              val rdict = ref (RlitDict.mkDict())              val rdict = ref (RlitDict.empty)
277              val rrtv = mkv()              val rrtv = mkv()
278              val rrtval = VAR rrtv              val rrtval = VAR rrtv
279        in        in
# Line 275  Line 282 
282              val rd = !rdict              val rd = !rdict
283              val rlit = toRlit s              val rlit = toRlit s
284              val n =              val n =
285                (case RlitDict.peek(rd, rlit)                (case RlitDict.find(rd, rlit)
286                  of SOME k => k                  of SOME k => k
287                   | _ => let val _ = (reals := (s :: (!reals)))                   | _ => let val _ = (reals := (s :: (!reals)))
288                              val k = !realsN                              val k = !realsN
# Line 352  Line 359 
359              val toplit =              val toplit =
360                let fun g ([], z) = LI_TOP z                let fun g ([], z) = LI_TOP z
361                      | g (x::r, z) =                      | g (x::r, z) =
362                           (case Intmap.map m x                           (case IntHashTable.lookup m x
363                             of ZZ_STR s => g(r, (LI_STRING s)::z)                             of ZZ_STR s => g(r, (LI_STRING s)::z)
364                              | _ => g(r, (LI_VAR x)::z))                              | _ => g(r, (LI_VAR x)::z))
365                 in g(exports, [])                 in g(exports, [])
366                end                end
367    
368              fun mklit (v, lit) =              fun mklit (v, lit) = let
369                (case Intmap.map m v                  fun unREAL (CPS.REAL s) = s
370                  of (ZZ_FLT _) => (* float is wrapped *)                    | unREAL _ = bug "unREAL"
371                    fun unINT32 (CPS.INT32 w) = w
372                      | unINT32 _ = bug "unINT32"
373                in
374                    case IntHashTable.lookup m v of
375                        (ZZ_FLT _) => (* float is wrapped *)
376                       bug "currently we don't expect ZZ_FLT in mklit"                       bug "currently we don't expect ZZ_FLT in mklit"
377                       (* LI_F64BLOCK([s], v, lit) *)                       (* LI_F64BLOCK([s], v, lit) *)
378                   | (ZZ_STR s) =>                   | (ZZ_STR s) =>
379                       bug "currently we don't expect ZZ_STR in mklit"                       bug "currently we don't expect ZZ_STR in mklit"
380                       (* lit   --- or we could inline string *)                       (* lit   --- or we could inline string *)
381                   | (ZZ_RCD(CPS.RK_FBLOCK, vs)) =>                   | (ZZ_RCD(CPS.RK_FBLOCK, vs)) =>
382                       LI_F64BLOCK(map (fn (CPS.REAL s) => s) vs, v, lit)                      LI_F64BLOCK(map unREAL vs, v, lit)
383                   | (ZZ_RCD(CPS.RK_I32BLOCK, vs)) =>                   | (ZZ_RCD(CPS.RK_I32BLOCK, vs)) =>
384                       LI_I32BLOCK(map (fn (CPS.INT32 w) => w) vs, v, lit)                     LI_I32BLOCK(map unINT32 vs, v, lit)
385                   | (ZZ_RCD(rk, vs)) =>                   | (ZZ_RCD(rk, vs)) =>
386                       LI_BLOCK(rk2bk rk, map val2lit vs, v, lit))                       LI_BLOCK(rk2bk rk, map val2lit vs, v, lit)
387                end
388    
389              (** build up the literal structure *)              (** build up the literal structure *)
390              val lit = foldl mklit toplit allvars              val lit = foldl mklit toplit allvars
# Line 386  Line 399 
399    
400                         fun mkhdr (v, (i, hh)) =                         fun mkhdr (v, (i, hh)) =
401                           let val nh =                           let val nh =
402                                 (case Intmap.map m v                                 (case IntHashTable.lookup m v
403                                   of (ZZ_FLT _) => bug "ZZ_FLT in mkhdr"                                   of (ZZ_FLT _) => bug "ZZ_FLT in mkhdr"
404                                        (* (fn ce =>                                        (* (fn ce =>
405                                             (SELECT(i, rval, w, PTRt(FPT 1),                                             (SELECT(i, rval, w, PTRt(FPT 1),
# Line 399  Line 412 
412                                            val t =                                            val t =
413                                              case rk                                              case rk
414                                               of RK_FBLOCK => PTRt(FPT n)                                               of RK_FBLOCK => PTRt(FPT n)
415                                                  | RK_VECTOR => BOGt
416                                                | _ => PTRt(RPT n)                                                | _ => PTRt(RPT n)
417                                         in fn ce => SELECT(i, rval, v, t, ce)                                         in fn ce => SELECT(i, rval, v, t, ce)
418                                        end)                                        end)
# Line 449  Line 463 
463             | PURE (p, ul, v, t, e) =>             | PURE (p, ul, v, t, e) =>
464                 let val (nl, hh) = lpvs ul                 let val (nl, hh) = lpvs ul
465                  in hh(PURE(p, nl, v, t, loop e))                  in hh(PURE(p, nl, v, t, loop e))
466                   end
467               | RCC (k, l, p, ul, vtl, e) =>
468                   let val (nl, hh) = lpvs ul
469                    in hh(RCC(k, l, p, nl, vtl, loop e))
470                 end)                 end)
471    
472        val newbody = loop body        val newbody = loop body
# Line 466  Line 484 
484    
485  end (* toplevel local *)  end (* toplevel local *)
486  end (* Literals *)  end (* Literals *)
   
 (*  
  * $Log$  
  *)  
   

Legend:
Removed from v.251  
changed lines
  Added in v.2162

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