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/src/compiler/FLINT/main/literals.sml
ViewVC logotype

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

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

revision 122, Sat Jun 6 15:05:38 1998 UTC revision 251, Mon Apr 19 02:55:26 1999 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        open CPS        open CPS
21  in  in
22    
23  fun bug msg = ErrorMsg.impossible ("Literals: "^msg)  fun bug msg = ErrorMsg.impossible ("Literals: "^msg)
24  val ident = fn x => x  val ident = fn x => x
 val liftLiterals = Control.FLINT.liftLiterals  
25  fun mkv _ = LV.mkLvar()  fun mkv _ = LV.mkLvar()
26    
27  (****************************************************************************  (****************************************************************************
28   *                         A MINI-LITERAL LANGUAGE                          *   *                         A MINI-LITERAL LANGUAGE                          *
29   ****************************************************************************)   ****************************************************************************)
30  datatype lit_val  datatype lit_val
31    = LI_INT of int    = LI_INT of word
   | LI_INT32 of Word32.word  
   | LI_REAL of string  
32    | LI_STRING of string    | LI_STRING of string
33    | LI_VAR of lvar    | LI_VAR of lvar
34    
35    datatype block_kind
36      = LI_RECORD           (* record of tagged ML values *)
37      | LI_VECTOR           (* vector of tagged ML values *)
38    
39  datatype lit_exp  datatype lit_exp
40    = LI_TOP of lit_val list    = LI_TOP of lit_val list
41    | LI_RECORD of record_kind * lit_val list * lvar * lit_exp    | LI_BLOCK of (block_kind * lit_val list * lvar * lit_exp)
42      | LI_F64BLOCK of (string list * lvar * lit_exp)
43      | LI_I32BLOCK of (Word32.word list * lvar * lit_exp)
44    
45  type lit = lit_exp  type lit = lit_exp
46    
47  fun val2lit (VAR v) = LI_VAR v  fun rk2bk CPS.RK_VECTOR = LI_VECTOR
48    | val2lit (INT i) = LI_INT i    | rk2bk CPS.RK_RECORD = LI_RECORD
49    | val2lit (INT32 i) = LI_INT32 i    | rk2bk _             = bug "rk2bk: unexpected block kind"
50    | val2lit (REAL s) = LI_REAL s  
51    | val2lit (STRING s) = LI_STRING s  fun val2lit (CPS.VAR v) = LI_VAR v
52      | val2lit (CPS.INT i) = LI_INT(Word.fromInt i)
53      | val2lit (CPS.STRING s) = LI_STRING s
54    | val2lit _ = bug "unexpected case in val2lit"    | val2lit _ = bug "unexpected case in val2lit"
55    
56  (****************************************************************************  (****************************************************************************
57   *                 TRANSLATING THE LITERAL EXP TO CPS EXP                   *   *                 TRANSLATING THE LITERAL EXP TO BYTES                     *
58   ****************************************************************************)   ****************************************************************************)
 fun lit2cps li =  
   let val k = mkv()  
59    
60        fun toval (LI_INT i) = INT i  (* Literals are encoded as instructions for a "literal machine."  The abstract
61          | toval (LI_INT32 i) = INT32 i   * description of these instructions is as follows:
62          | toval (LI_REAL s) = REAL s   *
63          | toval (LI_STRING s) = STRING s   *      INT(i)                  -- push the int31 literal i on the stack
64          | toval (LI_VAR v) = VAR v   *      RAW32[i1,...,in]        -- form a 32-bit raw data record from the
65     *                                 i1..in and push a pointer to it.
66        fun toexp (LI_TOP []) = APP(VAR k, [INT 0])   *      RAW64[r1,...,rn]        -- form a 64-bit raw data record from the
67          | toexp (LI_TOP vs) =   *                                 r1..rn and push a pointer to it.
68              let val v = mkv()   *      STR[c1,...,cn]          -- form a string from the characters c1..cn
69                  val nvs = map (fn x => (toval x, OFFp 0)) vs   *                                 and push it on the stack.
70               in RECORD(RK_RECORD, nvs, v, APP(VAR k, [VAR v]))   *      LIT(k)                  -- push the contents of the stack element
71              end   *                                 that is k slots from the top of the stack.
72          | toexp (LI_RECORD (rk, vs, v, e)) =   *      VECTOR(n)               -- pop n elements from the stack, make a vector
73              let val nvs = map (fn x => (toval x, OFFp 0)) vs   *                                 from them and push a pointer to the vector.
74               in RECORD(rk, nvs, v, toexp e)   *      RECORD(n)               -- pop n elements from the stack, make a record
75              end   *                                 from them and push a pointer.
76     *      RETURN                  -- return the literal that is on the top of the
77        val f = mkv()   *                                 stack.
78        val x = mkv()   *)
79     in (ESCAPE, f, [k, x], [CNTt, BOGt], toexp li)  
80    fun w32ToBytes' (w, l) =
81            Word8.fromLargeWord(Word32.>>(w, 0w24)) ::
82            Word8.fromLargeWord(Word32.>>(w, 0w16)) ::
83            Word8.fromLargeWord(Word32.>>(w, 0w8)) ::
84            Word8.fromLargeWord w :: l
85    fun w32ToBytes w = w32ToBytes' (w, [])
86    fun w31ToBytes w = w32ToBytes(Word31.toLargeWordX w)
87    fun intToBytes i = w32ToBytes(Word32.fromInt i)
88    fun intToBytes' (i, l) = w32ToBytes'(Word32.fromInt i, l)
89    fun strToBytes s = map Byte.charToByte (explode s)
90    
91    val emit_MAGIC = W8V.fromList[0wx19, 0wx98, 0wx10, 0wx22]
92    fun emit_DEPTH n = W8V.fromList(intToBytes n)
93    fun emit_INT i = W8V.fromList(0wx01 :: w31ToBytes i)
94    fun emit_RAW32 [i] = W8V.fromList(0wx02 :: w32ToBytes i)
95      | emit_RAW32 l =
96          W8V.fromList(0wx03 :: (intToBytes'(length l, List.foldr w32ToBytes' [] l)))
97    fun emit_RAW64 [r] = W8V.fromList(0wx04 :: strToBytes r)
98      | emit_RAW64 l = W8V.concat(
99          W8V.fromList(0wx05 :: intToBytes(length l)) :: map Byte.stringToBytes l)
100    fun emit_STR s = W8V.concat[
101            W8V.fromList(0wx06 :: intToBytes(size s)),
102            Byte.stringToBytes s
103          ]
104    fun emit_LIT k = W8V.fromList(0wx07 :: intToBytes k)
105    fun emit_VECTOR n = W8V.fromList(0wx08 :: intToBytes n)
106    fun emit_RECORD n = W8V.fromList(0wx09 :: intToBytes n)
107    val emit_RETURN = W8V.fromList[0wxff]
108    
109    fun litToBytes (LI_TOP[]) = W8V.fromList[]
110      | litToBytes litExp = let
111          fun depth (LI_TOP ls, d, maxDepth) = Int.max(maxDepth, d+length ls)
112            | depth (LI_BLOCK(_, ls, _, rest), d, maxDepth) =
113                depth (rest, d+1, Int.max(maxDepth, d+length ls))
114            | depth (LI_F64BLOCK(ls, _, rest), d, maxDepth) =
115                depth (rest, d+1, Int.max(maxDepth, d+length ls))
116            | depth (LI_I32BLOCK(ls, _, rest), d, maxDepth) =
117                depth (rest, d+1, Int.max(maxDepth, d+length ls))
118          fun emitLitExp (env, exp, code) = let
119                fun emitLitVals ([], _, code) = code
120                  | emitLitVals (lit::r, d, code) = let
121                      val instr = (case lit
122                             of (LI_INT i) => emit_INT i
123                              | (LI_STRING s) => emit_STR s
124                              | (LI_VAR v) => let
125                                  fun f ([], _) = bug "unbound lvar"
126                                    | f (v'::r, d) = if (v = v') then d else f(r, d+1)
127                                  in
128                                    emit_LIT(f (env, d))
129                                  end
130                            (* end case *))
131                      in
132                        emitLitVals (r, d+1, instr::code)
133                      end
134                fun emitBlock (LI_RECORD, ls, code) =
135                      emit_RECORD(length ls) :: emitLitVals(ls, 0, code)
136                  | emitBlock (LI_VECTOR, ls, code) =
137                      emit_VECTOR(length ls) :: emitLitVals(ls, 0, code)
138                fun emitF64Block (ls, code) =
139                      emit_RAW64(map IEEERealConst.realconst ls) :: code
140                fun emitI32Block (ls, code) = emit_RAW32 ls :: code
141                in
142                  case exp
143                   of (LI_TOP ls) => emit_RETURN :: emitBlock(LI_RECORD, ls, code)
144                    | (LI_BLOCK(bk, ls, v, rest)) =>
145                        emitLitExp (v::env, rest, emitBlock(bk, ls, code))
146                    | (LI_F64BLOCK(ls, v, rest)) =>
147                        emitLitExp (v::env, rest, emitF64Block(ls, code))
148                    | (LI_I32BLOCK(ls, v, rest)) =>
149                        emitLitExp (v::env, rest, emitI32Block(ls, code))
150                  (* end case *)
151                end
152          val maxDepth = depth (litExp, 0, 1)
153          val code = emit_MAGIC
154                :: emit_DEPTH maxDepth
155                :: List.rev(emitLitExp([], litExp, []))
156          in
157            W8V.concat code
158    end    end
159    
160    
# Line 80  Line 166 
166    
167  fun litsplit (FK_FCT, f, [(v, t)], body) =  fun litsplit (FK_FCT, f, [(v, t)], body) =
168        if LT.ltp_str t then        if LT.ltp_str t then
169          let val (nbody, lit, llt) =          let val (nbody, lit, llt) = liftlits body
               if !liftLiterals then liftlits body  
               else (body, LI_TOP [], LT.ltc_str[])  
170              val nt = LT.ltc_str ((LT.ltd_str t)@[llt])              val nt = LT.ltc_str ((LT.ltd_str t)@[llt])
171           in ((FK_FCT, f, [(v, nt)], body), lit)           in ((FK_FCT, f, [(v, nt)], body), lit)
172          end          end
# Line 128  Line 212 
212          | const (INT _ | INT32 _ | REAL _ | STRING _) = true          | const (INT _ | INT32 _ | REAL _ | STRING _) = true
213          | const _ = bug "unexpected case in const"          | const _ = bug "unexpected case in const"
214    
215          fun cstlit (VAR v) = ((Intmap.map m v; true) handle _ => false)
216            | cstlit (REAL _ | STRING _) = true
217            | cstlit _ = false
218    
219        (* register a string literal *)        (* register a string literal *)
220        local val strs : string list ref = ref []        local val strs : string list ref = ref []
221              val strsN : int ref = ref 0              val strsN : int ref = ref 0
# Line 226  Line 314 
314    
315        (* if all fields of a record are "constant", then we lift it *)        (* if all fields of a record are "constant", then we lift it *)
316        fun field ul =        fun field ul =
317          let fun h ((x, OFFp 0)::r, z) =          let fun h ((x, OFFp 0)::r, z, rsflag) =
318                   if const x then h(r, x::z) else NONE                   if const x then h(r, x::z, rsflag orelse (cstlit x)) else NONE
319                | h ([], z) = SOME(rev z)                | h ([], z, rsflag) = if rsflag then SOME(rev z) else NONE
320                | h _ = bug "unexpected case in field"                | h _ = bug "unexpected case in field"
321           in h (ul, [])           in h (ul, [], false)
322          end          end
323    
324        (* register a constant record *)        (* register a constant record *)
# Line 274  Line 362 
362                (case Intmap.map m v                (case Intmap.map m v
363                  of (ZZ_FLT _) => (* float is wrapped *)                  of (ZZ_FLT _) => (* float is wrapped *)
364                       bug "currently we don't expect ZZ_FLT in mklit"                       bug "currently we don't expect ZZ_FLT in mklit"
365                       (* LI_RECORD(RK_FBLOCK, [LI_REAL s], v, lit) *)                       (* LI_F64BLOCK([s], v, lit) *)
366                   | (ZZ_STR s) =>                   | (ZZ_STR s) =>
367                       bug "currently we don't expect ZZ_STR in mklit"                       bug "currently we don't expect ZZ_STR in mklit"
368                       (* lit   --- or we could inline string *)                       (* lit   --- or we could inline string *)
369                     | (ZZ_RCD(CPS.RK_FBLOCK, vs)) =>
370                         LI_F64BLOCK(map (fn (CPS.REAL s) => s) vs, v, lit)
371                     | (ZZ_RCD(CPS.RK_I32BLOCK, vs)) =>
372                         LI_I32BLOCK(map (fn (CPS.INT32 w) => w) vs, v, lit)
373                   | (ZZ_RCD (rk, vs)) =>                   | (ZZ_RCD (rk, vs)) =>
374                       LI_RECORD(rk, map val2lit vs, v, lit))                       LI_BLOCK(rk2bk rk, map val2lit vs, v, lit))
375    
376              (** build up the literal structure *)              (** build up the literal structure *)
377              val lit = foldl mklit toplit allvars              val lit = foldl mklit toplit allvars
# Line 367  Line 459 
459  (* the main function *)  (* the main function *)
460  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) =
461        let val nt = PTRt(RPT (n+1))        let val nt = PTRt(RPT (n+1))
462            val (nbody, lit) =            val (nbody, lit) = liftlits(body, VAR x, n)
             if !liftLiterals then liftlits(body, VAR x, n)  
             else (body, LI_TOP [])  
   
463         in ((fk, f, vl, [CNTt, nt], nbody), lit)         in ((fk, f, vl, [CNTt, nt], nbody), lit)
464        end        end
465    | litsplit _ = bug "unexpected CPS header in litsplit"    | litsplit _ = bug "unexpected CPS header in litsplit"
# Line 378  Line 467 
467  end (* toplevel local *)  end (* toplevel local *)
468  end (* Literals *)  end (* Literals *)
469    
470    (*
471     * $Log$
472     *)
473    

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

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