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 651, Thu Jun 1 18:34:03 2000 UTC sml/trunk/compiler/FLINT/main/literals.sml revision 2162, Thu Nov 2 21:20:47 2006 UTC
# Line 204  Line 204 
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 214  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 359  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 393  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 457  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

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

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