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

revision 4516, Sat Oct 28 17:51:15 2017 UTC revision 4527, Sat Apr 14 14:41:11 2018 UTC
# Line 63  Line 63 
63      datatype lit_exp      datatype lit_exp
64        = LI_TOP of lit_val list        = LI_TOP of lit_val list
65        | LI_BLOCK of (block_kind * lit_val list * lvar * lit_exp)        | LI_BLOCK of (block_kind * lit_val list * lvar * lit_exp)
66        | LI_F64BLOCK of (string list * lvar * lit_exp)        | LI_F64BLOCK of (RealLit.t list * lvar * lit_exp)
67        | LI_I32BLOCK of (Word32.word list * lvar * lit_exp)        | LI_I32BLOCK of (Word32.word list * lvar * lit_exp)
68    
69      fun rk2bk CPS.RK_VECTOR     = LI_VECTOR      fun rk2bk CPS.RK_VECTOR     = LI_VECTOR
# Line 128  Line 128 
128      fun emit_RAW32 [i] = W8V.fromList(0wx02 :: w32ToBytes i)      fun emit_RAW32 [i] = W8V.fromList(0wx02 :: w32ToBytes i)
129        | emit_RAW32 l =        | emit_RAW32 l =
130            W8V.fromList(0wx03 :: (intToBytes'(length l, List.foldr w32ToBytes' [] l)))            W8V.fromList(0wx03 :: (intToBytes'(length l, List.foldr w32ToBytes' [] l)))
131      fun emit_RAW64 [r] = W8V.fromList(0wx04 :: strToBytes r)      fun emit_RAW64 [r] = W8V.fromList(0wx04 :: Word8Vector.toList r)
132        | emit_RAW64 l = W8V.concat(        | emit_RAW64 l = W8V.concat(W8V.fromList(0wx05 :: intToBytes(length l)) :: l)
           W8V.fromList(0wx05 :: intToBytes(length l)) :: map Byte.stringToBytes l)  
133      fun emit_STR s = W8V.concat[      fun emit_STR s = W8V.concat[
134              W8V.fromList(0wx06 :: intToBytes(size s)),              W8V.fromList(0wx06 :: intToBytes(size s)),
135              Byte.stringToBytes s              Byte.stringToBytes s
# Line 169  Line 168 
168                        emit_RECORD(length ls) :: emitLitVals(ls, 0, code)                        emit_RECORD(length ls) :: emitLitVals(ls, 0, code)
169                    | emitBlock (LI_VECTOR, ls, code) =                    | emitBlock (LI_VECTOR, ls, code) =
170                        emit_VECTOR(length ls) :: emitLitVals(ls, 0, code)                        emit_VECTOR(length ls) :: emitLitVals(ls, 0, code)
171                  fun emitF64Block (ls, code) =                  fun emitF64Block (ls, code) = let
172                        emit_RAW64(map IEEERealConst.realconst ls) :: code                        val toBits = #1 o Real64ToBits.toBits
173                          in
174                            emit_RAW64(map toBits ls) :: code
175                          end
176                  fun emitI32Block (ls, code) = emit_RAW32 ls :: code                  fun emitI32Block (ls, code) = emit_RAW32 ls :: code
177                  in                  in
178                    case exp                    case exp
# Line 201  Line 203 
203    
204      exception LitInfo      exception LitInfo
205    
206      datatype rlit = RLIT of string * word  (* FIXME: we should probably either use hash tables or the raw comparison
207      fun toRlit s = RLIT(s, HashString.hashString s)   * functions to implement the dictionaries.
208      fun fromRlit (RLIT(s, _)) = s   *)
209      fun rlitcmp (RLIT(s1,i1), RLIT(s2,i2)) =  
210      (* string literal dictionary *)
211        datatype slit = SLIT of string * word
212        fun toSlit s = SLIT(s, HashString.hashString s)
213        fun fromSlit (SLIT(s, _)) = s
214        structure SlitDict = RedBlackMapFn(
215          struct
216            type ord_key = slit
217            fun compare (SLIT(s1,i1), SLIT(s2,i2)) =
218                  if i1 < i2 then LESS
219                  else if i1 > i2 then GREATER
220                  else String.compare(s1, s2)
221          end)
222    
223      (* real literal dictionary *)
224        datatype rlit = RLIT of RealLit.t * word
225        fun toRlit r = RLIT(r, RealLit.hash r)
226        fun fromRlit (RLIT(r, _)) = r
227        structure RlitDict = RedBlackMapFn(
228          struct
229            type ord_key = rlit
230            fun compare (RLIT(r1,i1), RLIT(r2,i2)) =
231        if i1 < i2 then LESS        if i1 < i2 then LESS
232        else if i1 > i2 then GREATER else String.compare(s1, s2)            else if i1 > i2 then GREATER
233      structure RlitDict = RedBlackMapFn(struct type ord_key = rlit            else RealLit.compare(r1, r2)
                                             val compare = rlitcmp  
234                                       end)                                       end)
235    
236      (* lifting all literals from a CPS program *)      (* lifting all literals from a CPS program *)
237      fun liftlits (body, root, offset) =      fun liftlits (body, root, offset) = let
238        let (* the list of record, string, or real constants *)          (* the list of record, string, and real constants *)
239            val m : info IntHashTable.hash_table = IntHashTable.mkTable(32, LitInfo)            val m : info IntHashTable.hash_table = IntHashTable.mkTable(32, LitInfo)
240            val freevars : lvar list ref = ref []            val freevars : lvar list ref = ref []
241            fun addv x = (freevars := (x :: (!freevars)))            fun addv x = (freevars := (x :: (!freevars)))
   
242            (* check if an lvar is used by the main program *)            (* check if an lvar is used by the main program *)
243            val refset : Intset.intset = Intset.new()            val refset : Intset.intset = Intset.new()
244            val used : lvar -> unit = Intset.add refset            val used : lvar -> unit = Intset.add refset
245            val isUsed : lvar -> bool = Intset.mem refset            val isUsed : lvar -> bool = Intset.mem refset
   
246            (* memoize the information on which corresponds to what *)            (* memoize the information on which corresponds to what *)
247            fun enter (v, i) = (IntHashTable.insert m (v, i); addv v)            fun enter (v, i) = (IntHashTable.insert m (v, i); addv v)
248            fun const (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)            fun const (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
249              | const (INT _ | INT32 _ | REAL _ | STRING _) = true              | const (INT _ | INT32 _ | REAL _ | STRING _) = true
250              | const _ = bug "unexpected case in const"              | const _ = bug "unexpected case in const"
   
251            fun cstlit (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)            fun cstlit (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
252              | cstlit (REAL _ | STRING _) = true              | cstlit (REAL _ | STRING _) = true
253              | cstlit _ = false              | cstlit _ = false
   
254            (* register a string literal *)            (* register a string literal *)
255            local val strs : string list ref = ref []            local val strs : string list ref = ref []
256                  val strsN : int ref = ref 0                  val strsN : int ref = ref 0
257                  val sdict = ref (RlitDict.empty)                  val sdict = ref (SlitDict.empty)
258                  val srtv = mkv()                  val srtv = mkv()
259                  val srtval = VAR srtv                  val srtval = VAR srtv
260            in            in
261            fun entStr s =            fun entStr s = let
262              let val v = mkv()  (** should hash to remove duplicates **)                  val v = mkv()  (** should hash to remove duplicates **)
263                  val sd = !sdict                  val sd = !sdict
264                  val rlit = toRlit s                  val rlit = toSlit s
265                  val n =                  val n = (case SlitDict.find(sd, rlit)
                   (case RlitDict.find(sd, rlit)  
266                      of SOME k => k                      of SOME k => k
267                       | _ => let val _ = (strs := (s :: (!strs)))                          | _ => let
268                                val _ = (strs := (s :: (!strs)))
269                                  val k = !strsN                                  val k = !strsN
270                                  val _ = (strsN := (k+1))                                  val _ = (strsN := (k+1))
271                                  val _ = (sdict := (RlitDict.insert(sd, rlit, k)))                              val _ = (sdict := (SlitDict.insert(sd, rlit, k)))
272                               in k                              in
273                              end)                                k
              in (VAR v, fn ce => SELECT(n, srtval, v, BOGt, ce))  
             end  
   
     (* old definition of entStr  
   
             let val sd = !sdict  
                 val rlit = toRlit s  
              in (case RlitDict.peek(sd, rlit)  
                   of SOME v => (VAR v, ident)  
                    | _ => let val v = mkv()  
                               val _ = (enter(v, ZZ_STR s); used v)  
                               val _ = (sdict := RlitDict.insert(sd, rlit, v))  
                            in (VAR v, ident)  
274                            end)                            end)
275                    in
276                      (VAR v, fn ce => SELECT(n, srtval, v, BOGt, ce))
277              end              end
278      *)            fun appStr () = let
279                    fun g (a::r, z) = g(r, (STRING a)::z)
           fun appStr () =  
             let fun g (a::r, z) = g(r, (STRING a)::z)  
280                    | g ([], z) = z (* reverse to reflecting the correct order *)                    | g ([], z) = z (* reverse to reflecting the correct order *)
281                  val allStrs = !strs                  val allStrs = !strs
282               in case !strs                  in
283                      case !strs
284                   of [] => ()                   of [] => ()
285                    | xs => (enter(srtv, ZZ_RCD(RK_RECORD, g(xs,[]))); used srtv)                    | xs => (enter(srtv, ZZ_RCD(RK_RECORD, g(xs,[]))); used srtv)
286                      (* end case *)
287              end              end
288            end (* local of processing string literals *)            end (* local of processing string literals *)
289            (* register a real literal *)
290            (** a special treatment of real constants *)            local val reals : RealLit.t list ref = ref []
           local val reals : string list ref = ref []  
291                  val realsN : int ref = ref 0                  val realsN : int ref = ref 0
292                  val rdict = ref (RlitDict.empty)                  val rdict = ref (RlitDict.empty)
293                  val rrtv = mkv()                  val rrtv = mkv()
294                  val rrtval = VAR rrtv                  val rrtval = VAR rrtv
295            in            in
296            fun entReal s =            fun entReal s = let
297              let val v = mkv()  (** should hash to remove duplicates **)                  val v = mkv()  (** should hash to remove duplicates **)
298                  val rd = !rdict                  val rd = !rdict
299                  val rlit = toRlit s                  val rlit = toRlit s
300                  val n =                  val n = (case RlitDict.find(rd, rlit)
                   (case RlitDict.find(rd, rlit)  
301                      of SOME k => k                      of SOME k => k
302                       | _ => let val _ = (reals := (s :: (!reals)))                          | _ => let
303                                val _ = (reals := (s :: (!reals)))
304                                  val k = !realsN                                  val k = !realsN
305                                  val _ = (realsN := (k+1))                                  val _ = (realsN := (k+1))
306                                  val _ = (rdict := (RlitDict.insert(rd, rlit, k)))                                  val _ = (rdict := (RlitDict.insert(rd, rlit, k)))
307                               in k                              in
308                                  k
309                              end)                              end)
310               in (VAR v, fn ce => SELECT(n, rrtval, v, FLTt 64, ce))     (* REAL32: FIXME *)                  in
311                      (VAR v, fn ce => SELECT(n, rrtval, v, FLTt 64, ce))   (* REAL32: FIXME *)
312              end              end
313              fun appReal () = let
314            fun appReal () =                  fun g (a::r, z) = g(r, (REAL a)::z)
             let fun g (a::r, z) = g(r, (REAL a)::z)  
315                    | g ([], z) = z (* reverse to reflecting the correct order *)                    | g ([], z) = z (* reverse to reflecting the correct order *)
316                  val allReals = !reals                  val allReals = !reals
317               in case !reals                  in
318                      case !reals
319                   of [] => ()                   of [] => ()
320                    | xs => (enter(rrtv, ZZ_RCD(RK_FBLOCK, g(xs,[]))); used rrtv)                    | xs => (enter(rrtv, ZZ_RCD(RK_FBLOCK, g(xs,[]))); used rrtv)
321              end              end
322            end (* local of special treatment of real constants *)            end (* local of processing real literals *)
   
323            (* translation on the CPS values *)            (* translation on the CPS values *)
324            fun lpsv u =            fun lpsv u = (case u
325              (case u                   of REAL r => entReal r
               of REAL s => entReal s  
326                 | STRING s => entStr s                 | STRING s => entStr s
327                 | VAR v => (used v; (u, Fn.id))                 | VAR v => (used v; (u, Fn.id))
328                 | _ => (u, Fn.id))                    | _ => (u, Fn.id)
329                    (* end case *))
330            fun lpvs vs =            fun lpvs vs = let
331              let fun g (u, (xs, hh)) =                  fun g (u, (xs, hh)) = let
332                    let val (nu, nh) = lpsv u                        val (nu, nh) = lpsv u
333                     in (nu::xs, nh o hh)                        in
334                            (nu::xs, nh o hh)
335                    end                    end
336               in foldr g ([], Fn.id) vs                  in
337                      foldr g ([], Fn.id) vs
338              end              end
   
339            (* if all fields of a record are "constant", then we lift it *)            (* if all fields of a record are "constant", then we lift it *)
340            fun field ul =            fun field ul = let
341              let fun h ((x, OFFp 0)::r, z, rsflag) =                 fun h ((x, OFFp 0)::r, z, rsflag) = if const x
342                       if const x then h(r, x::z, rsflag orelse (cstlit x)) else NONE                          then h(r, x::z, rsflag orelse (cstlit x))
343                            else NONE
344                    | h ([], z, rsflag) = if rsflag then SOME(rev z) else NONE                    | h ([], z, rsflag) = if rsflag then SOME(rev z) else NONE
345                    | h _ = bug "unexpected case in field"                    | h _ = bug "unexpected case in field"
346               in h (ul, [], false)                  in
347                      h (ul, [], false)
348              end              end
   
349            (* register a constant record *)            (* register a constant record *)
350            fun record (rk, ul, v) =            fun record (rk, ul, v) = (case field ul
             (case field ul  
351                of SOME xl => (enter(v, ZZ_RCD(rk, xl)); Fn.id)                of SOME xl => (enter(v, ZZ_RCD(rk, xl)); Fn.id)
352                 | NONE =>                    | NONE => let
353                     let fun g ((u, p as OFFp 0), (r, hh)) =                        fun g ((u, p as OFFp 0), (r, hh)) = let
354                               let val (nu, nh) = lpsv u                                val (nu, nh) = lpsv u
355                                in ((nu, p)::r, nh o hh)                                in
356                                    ((nu, p)::r, nh o hh)
357                               end                               end
358                           | g _ = bug "unexpected non-zero OFFp in record"                           | g _ = bug "unexpected non-zero OFFp in record"
359                         val (nl, hdr) = foldr g ([], Fn.id) ul                         val (nl, hdr) = foldr g ([], Fn.id) ul
360                      in fn ce => hdr(RECORD(rk, nl, v, ce))                        in
361                            fn ce => hdr(RECORD(rk, nl, v, ce))
362                     end)                     end)
   
363            (* register a wrapped float literal *)            (* register a wrapped float literal *)
364            fun wrapfloat (u, v, t) =            fun wrapfloat (u, v, t) = if const u
365              if const u then (enter(v, ZZ_RCD(RK_FBLOCK, [u])); Fn.id)                  then (enter(v, ZZ_RCD(RK_FBLOCK, [u])); Fn.id)
366              else let val (nu, hh) = lpsv u              else let val (nu, hh) = lpsv u
367                    in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))                    in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))
368                   end                   end
   
369            (* fetch out the literal information *)            (* fetch out the literal information *)
370            fun getInfo () =            fun getInfo () = let
371              let val _ = appReal()   (* register all Reals as a record *)                  val _ = appReal()   (* register all Reals as a record *)
372                  val _ = appStr()   (* register all Strings as a record *)                  val _ = appStr()   (* register all Strings as a record *)
373                  val allvars = !freevars                  val allvars = !freevars
374                  val exports = List.filter isUsed allvars                  val exports = List.filter isUsed allvars
# Line 376  Line 383 
383                    end                    end
384    
385                  fun mklit (v, lit) = let                  fun mklit (v, lit) = let
386                      fun unREAL (CPS.REAL s) = s                      fun unREAL (CPS.REAL r) = r
387                        | unREAL _ = bug "unREAL"                        | unREAL _ = bug "unREAL"
388                      fun unINT32 (CPS.INT32 w) = w                      fun unINT32 (CPS.INT32 w) = w
389                        | unINT32 _ = bug "unINT32"                        | unINT32 _ = bug "unINT32"
390                  in                  in
391                      case IntHashTable.lookup m v of                        case IntHashTable.lookup m v
392                          (ZZ_FLT _) => (* float is wrapped *)                         of (ZZ_FLT _) => (* float is wrapped *)
393                          bug "currently we don't expect ZZ_FLT in mklit"                          bug "currently we don't expect ZZ_FLT in mklit"
394                        (* LI_F64BLOCK([s], v, lit) *)                        (* LI_F64BLOCK([s], v, lit) *)
395                        | (ZZ_STR s) =>                        | (ZZ_STR s) =>
# Line 435  Line 442 
442    
443            fun lpfn (fk, f, vl, cl, e) = (fk, f, vl, cl, loop e)            fun lpfn (fk, f, vl, cl, e) = (fk, f, vl, cl, loop e)
444    
445            and loop ce =            and loop ce = (case ce
             (case ce  
446                of RECORD (rk, ul, v, e) => record (rk, ul, v) (loop e)                of RECORD (rk, ul, v, e) => record (rk, ul, v) (loop e)
447                 | SELECT (i, u, v, t, e) =>                 | SELECT (i, u, v, t, e) =>
448                     let val (nu, hh) = lpsv u                     let val (nu, hh) = lpsv u

Legend:
Removed from v.4516  
changed lines
  Added in v.4527

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