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 477, Wed Nov 10 23:04:21 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 190  Line 197 
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 = BinaryMapFn(struct type ord_key = rlit  structure RlitDict = RedBlackMapFn(struct type ord_key = rlit
201                                          val compare = 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    
# 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 450  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 467  Line 484 
484    
485  end (* toplevel local *)  end (* toplevel local *)
486  end (* Literals *)  end (* Literals *)
   
 (*  
  * $Log$  
  *)  
   

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

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