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 98, Thu May 14 04:54:52 1998 UTC sml/trunk/compiler/FLINT/main/literals.sml revision 2162, Thu Nov 2 21:20:47 2006 UTC
# Line 1  Line 1 
1  (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)  (* literals.sml
2  (* literals.sml *)   *
3     * COPYRIGHT (c) 1998 Bell Labs, Lucent Technologies.
4     * COPYRIGHT (c) 1998 YALE FLINT PROJECT.
5     *)
6    
7  signature LITERALS =  signature LITERALS =
8   sig   sig
9     type lit     type lit
10     val litsplit : CPS.function -> CPS.function * lit     val litsplit : CPS.function -> CPS.function * lit
11     val lit2cps : lit -> CPS.function     val litToBytes : lit -> Word8Vector.vector
12   end   end;
13    
14  structure Literals : LITERALS =  structure Literals : LITERALS =
15  struct  struct
16    
17    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    
30  fun bug msg = ErrorMsg.impossible ("Literals: "^msg)  fun bug msg = ErrorMsg.impossible ("Literals: "^msg)
31  val ident = fn x => x  val ident = fn x => x
 val liftLiterals = Control.CG.liftLiterals  
32  fun mkv _ = LV.mkLvar()  fun mkv _ = LV.mkLvar()
33    
34  (****************************************************************************  (****************************************************************************
35   *                         A MINI-LITERAL LANGUAGE                          *   *                         A MINI-LITERAL LANGUAGE                          *
36   ****************************************************************************)   ****************************************************************************)
37  datatype lit_val  datatype lit_val
38    = LI_INT of int    = LI_INT of word
   | LI_INT32 of Word32.word  
   | LI_REAL of string  
39    | LI_STRING of string    | LI_STRING of string
40    | LI_VAR of lvar    | LI_VAR of lvar
41    
42    datatype block_kind
43      = LI_RECORD           (* record of tagged ML values *)
44      | LI_VECTOR           (* vector of tagged ML values *)
45    
46  datatype lit_exp  datatype lit_exp
47    = LI_TOP of lit_val list    = LI_TOP of lit_val list
48    | LI_RECORD of record_kind * lit_val list * lvar * lit_exp    | LI_BLOCK of (block_kind * lit_val list * lvar * lit_exp)
49      | LI_F64BLOCK of (string list * lvar * lit_exp)
50      | LI_I32BLOCK of (Word32.word list * lvar * lit_exp)
51    
52  type lit = lit_exp  type lit = lit_exp
53    
54  fun val2lit (VAR v) = LI_VAR v  fun rk2bk CPS.RK_VECTOR = LI_VECTOR
55    | val2lit (INT i) = LI_INT i    | rk2bk CPS.RK_RECORD = LI_RECORD
56    | val2lit (INT32 i) = LI_INT32 i    | rk2bk _             = bug "rk2bk: unexpected block kind"
57    | val2lit (REAL s) = LI_REAL s  
58    | val2lit (STRING s) = LI_STRING s  fun val2lit (CPS.VAR v) = LI_VAR v
59      | val2lit (CPS.INT i) = LI_INT(Word.fromInt i)
60      | val2lit (CPS.STRING s) = LI_STRING s
61    | val2lit _ = bug "unexpected case in val2lit"    | val2lit _ = bug "unexpected case in val2lit"
62    
63  (****************************************************************************  (****************************************************************************
64   *                 TRANSLATING THE LITERAL EXP TO CPS EXP                   *   *                 TRANSLATING THE LITERAL EXP TO BYTES                     *
65   ****************************************************************************)   ****************************************************************************)
 fun lit2cps li =  
   let val k = mkv()  
66    
67        fun toval (LI_INT i) = INT i  (* Literals are encoded as instructions for a "literal machine."  The abstract
68          | toval (LI_INT32 i) = INT32 i   * description of these instructions is as follows:
69          | toval (LI_REAL s) = REAL s   *
70          | toval (LI_STRING s) = STRING s   *      INT(i)                  -- push the int31 literal i on the stack
71          | toval (LI_VAR v) = VAR v   *      RAW32[i1,...,in]        -- form a 32-bit raw data record from the
72     *                                 i1..in and push a pointer to it.
73        fun toexp (LI_TOP []) = APP(VAR k, [INT 0])   *      RAW64[r1,...,rn]        -- form a 64-bit raw data record from the
74          | toexp (LI_TOP vs) =   *                                 r1..rn and push a pointer to it.
75              let val v = mkv()   *      STR[c1,...,cn]          -- form a string from the characters c1..cn
76                  val nvs = map (fn x => (toval x, OFFp 0)) vs   *                                 and push it on the stack.
77               in RECORD(RK_RECORD, nvs, v, APP(VAR k, [VAR v]))   *      LIT(k)                  -- push the contents of the stack element
78              end   *                                 that is k slots from the top of the stack.
79          | toexp (LI_RECORD (rk, vs, v, e)) =   *      VECTOR(n)               -- pop n elements from the stack, make a vector
80              let val nvs = map (fn x => (toval x, OFFp 0)) vs   *                                 from them and push a pointer to the vector.
81               in RECORD(rk, nvs, v, toexp e)   *      RECORD(n)               -- pop n elements from the stack, make a record
82              end   *                                 from them and push a pointer.
83     *      RETURN                  -- return the literal that is on the top of the
84        val f = mkv()   *                                 stack.
85        val x = mkv()   *)
86     in (ESCAPE, f, [k, x], [CNTt, BOGt], toexp li)  
87    fun w32ToBytes' (w, l) =
88            Word8.fromLargeWord(Word32.>>(w, 0w24)) ::
89            Word8.fromLargeWord(Word32.>>(w, 0w16)) ::
90            Word8.fromLargeWord(Word32.>>(w, 0w8)) ::
91            Word8.fromLargeWord w :: l
92    fun w32ToBytes w = w32ToBytes' (w, [])
93    fun w31ToBytes w = w32ToBytes(Word31.toLargeWordX w)
94    fun intToBytes i = w32ToBytes(Word32.fromInt i)
95    fun intToBytes' (i, l) = w32ToBytes'(Word32.fromInt i, l)
96    fun strToBytes s = map Byte.charToByte (explode s)
97    
98    val emit_MAGIC = W8V.fromList[0wx19, 0wx98, 0wx10, 0wx22]
99    fun emit_DEPTH n = W8V.fromList(intToBytes n)
100    fun emit_INT i = W8V.fromList(0wx01 :: w31ToBytes i)
101    fun emit_RAW32 [i] = W8V.fromList(0wx02 :: w32ToBytes i)
102      | emit_RAW32 l =
103          W8V.fromList(0wx03 :: (intToBytes'(length l, List.foldr w32ToBytes' [] l)))
104    fun emit_RAW64 [r] = W8V.fromList(0wx04 :: strToBytes r)
105      | emit_RAW64 l = W8V.concat(
106          W8V.fromList(0wx05 :: intToBytes(length l)) :: map Byte.stringToBytes l)
107    fun emit_STR s = W8V.concat[
108            W8V.fromList(0wx06 :: intToBytes(size s)),
109            Byte.stringToBytes s
110          ]
111    fun emit_LIT k = W8V.fromList(0wx07 :: intToBytes k)
112    fun emit_VECTOR n = W8V.fromList(0wx08 :: intToBytes n)
113    fun emit_RECORD n = W8V.fromList(0wx09 :: intToBytes n)
114    val emit_RETURN = W8V.fromList[0wxff]
115    
116    fun litToBytes (LI_TOP[]) = W8V.fromList[]
117      | litToBytes litExp = let
118          fun depth (LI_TOP ls, d, maxDepth) = Int.max(maxDepth, d+length ls)
119            | depth (LI_BLOCK(_, ls, _, rest), d, maxDepth) =
120                depth (rest, d+1, Int.max(maxDepth, d+length ls))
121            | depth (LI_F64BLOCK(ls, _, rest), d, maxDepth) =
122                depth (rest, d+1, Int.max(maxDepth, d+length ls))
123            | depth (LI_I32BLOCK(ls, _, rest), d, maxDepth) =
124                depth (rest, d+1, Int.max(maxDepth, d+length ls))
125          fun emitLitExp (env, exp, code) = let
126                fun emitLitVals ([], _, code) = code
127                  | emitLitVals (lit::r, d, code) = let
128                      val instr = (case lit
129                             of (LI_INT i) => emit_INT i
130                              | (LI_STRING s) => emit_STR s
131                              | (LI_VAR v) => let
132                                  fun f ([], _) = bug "unbound lvar"
133                                    | f (v'::r, d) = if (v = v') then d else f(r, d+1)
134                                  in
135                                    emit_LIT(f (env, d))
136                                  end
137                            (* end case *))
138                      in
139                        emitLitVals (r, d+1, instr::code)
140                      end
141                fun emitBlock (LI_RECORD, ls, code) =
142                      emit_RECORD(length ls) :: emitLitVals(ls, 0, code)
143                  | emitBlock (LI_VECTOR, ls, code) =
144                      emit_VECTOR(length ls) :: emitLitVals(ls, 0, code)
145                fun emitF64Block (ls, code) =
146                      emit_RAW64(map IEEERealConst.realconst ls) :: code
147                fun emitI32Block (ls, code) = emit_RAW32 ls :: code
148                in
149                  case exp
150                   of (LI_TOP ls) => emit_RETURN :: emitBlock(LI_RECORD, ls, code)
151                    | (LI_BLOCK(bk, ls, v, rest)) =>
152                        emitLitExp (v::env, rest, emitBlock(bk, ls, code))
153                    | (LI_F64BLOCK(ls, v, rest)) =>
154                        emitLitExp (v::env, rest, emitF64Block(ls, code))
155                    | (LI_I32BLOCK(ls, v, rest)) =>
156                        emitLitExp (v::env, rest, emitI32Block(ls, code))
157                  (* end case *)
158                end
159          val maxDepth = depth (litExp, 0, 1)
160          val code = emit_MAGIC
161                :: emit_DEPTH maxDepth
162                :: List.rev(emitLitExp([], litExp, []))
163          in
164            W8V.concat code
165    end    end
166    
167    
# Line 80  Line 173 
173    
174  fun litsplit (FK_FCT, f, [(v, t)], body) =  fun litsplit (FK_FCT, f, [(v, t)], body) =
175        if LT.ltp_str t then        if LT.ltp_str t then
176          let val (nbody, lit, llt) =          let val (nbody, lit, llt) = liftlits body
               if !liftLiterals then liftlits body  
               else (body, LI_TOP [], LT.ltc_str[])  
177              val nt = LT.ltc_str ((LT.ltd_str t)@[llt])              val nt = LT.ltc_str ((LT.ltd_str t)@[llt])
178           in ((FK_FCT, f, [(v, nt)], body), lit)           in ((FK_FCT, f, [(v, nt)], body), lit)
179          end          end
# Line 100  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 123  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) = ((IntHashTable.lookup m v; true) handle _ => false)
223            | cstlit (REAL _ | STRING _) = true
224            | 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 140  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 178  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 187  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 226  Line 321 
321    
322        (* if all fields of a record are "constant", then we lift it *)        (* if all fields of a record are "constant", then we lift it *)
323        fun field ul =        fun field ul =
324          let fun h ((x, OFFp 0)::r, z) =          let fun h ((x, OFFp 0)::r, z, rsflag) =
325                   if const x then h(r, x::z) else NONE                   if const x then h(r, x::z, rsflag orelse (cstlit x)) else NONE
326                | h ([], z) = SOME(rev z)                | h ([], z, rsflag) = if rsflag then SOME(rev z) else NONE
327                | h _ = bug "unexpected case in field"                | h _ = bug "unexpected case in field"
328           in h (ul, [])           in h (ul, [], false)
329          end          end
330    
331        (* register a constant record *)        (* register a constant record *)
# Line 264  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_RECORD(RK_FBLOCK, [LI_REAL 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)) =>
382                        LI_F64BLOCK(map unREAL vs, v, lit)
383                     | (ZZ_RCD(CPS.RK_I32BLOCK, vs)) =>
384                       LI_I32BLOCK(map unINT32 vs, v, lit)
385                   | (ZZ_RCD (rk, vs)) =>                   | (ZZ_RCD (rk, vs)) =>
386                       LI_RECORD(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 294  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 307  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 357  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 367  Line 477 
477  (* the main function *)  (* the main function *)
478  fun litsplit (fk, f, vl as [_,x], [CNTt, t as PTRt(RPT n)], body) =  fun litsplit (fk, f, vl as [_,x], [CNTt, t as PTRt(RPT n)], body) =
479        let val nt = PTRt(RPT (n+1))        let val nt = PTRt(RPT (n+1))
480            val (nbody, lit) =            val (nbody, lit) = liftlits(body, VAR x, n)
             if !liftLiterals then liftlits(body, VAR x, n)  
             else (body, LI_TOP [])  
   
481         in ((fk, f, vl, [CNTt, nt], nbody), lit)         in ((fk, f, vl, [CNTt, nt], nbody), lit)
482        end        end
483    | litsplit _ = bug "unexpected CPS header in litsplit"    | litsplit _ = bug "unexpected CPS header in litsplit"
484    
485  end (* toplevel local *)  end (* toplevel local *)
486  end (* Literals *)  end (* Literals *)
   

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

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