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/CPS/cps/ppcps.sml
ViewVC logotype

Diff of /sml/trunk/compiler/CPS/cps/ppcps.sml

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

revision 4953, Mon Apr 8 17:31:53 2019 UTC revision 4960, Tue Apr 16 10:26:22 2019 UTC
# Line 13  Line 13 
13      val printcps0: CPS.function -> unit      val printcps0: CPS.function -> unit
14      val prcps : CPS.cexp -> unit      val prcps : CPS.cexp -> unit
15    
16      (* string conversions for various CPS.P types *)
17        val numkindToString : CPS.P.numkind -> string
18        val arithopToString : CPS.P.arithop -> string
19        val cmpopToString : CPS.P.cmpop -> string
20        val fcmpopToString : CPS.P.fcmpop -> string
21        val branchToString : CPS.P.branch -> string
22        val setterToString : CPS.P.setter -> string
23        val lookerToString : CPS.P.looker -> string
24        val arithToString : CPS.P.arith -> string
25        val pureToString : CPS.P.pure -> string
26    
27    end (* signature PPCPS *)    end (* signature PPCPS *)
28    
29  structure PPCps : PPCPS =  structure PPCps : PPCPS =
30  struct  struct
31    
32  local open CPS      open CPS
33        structure LV = LambdaVar        structure LV = LambdaVar
34        structure U = CPSUtil        structure U = CPSUtil
 in  
35    
36  val say = Control.Print.say  val say = Control.Print.say
37    
# Line 40  Line 50 
50    | value2str (STRING s) = concat["\"", String.toString s, "\""]    | value2str (STRING s) = concat["\"", String.toString s, "\""]
51    | value2str (VOID) = "(void)"    | value2str (VOID) = "(void)"
52    
53  fun numkindName (P.INT bits) = "i" ^ Int.toString bits      fun numkindToString (P.INT bits) = "i" ^ Int.toString bits
54    | numkindName (P.UINT bits) = "u" ^ Int.toString bits        | numkindToString (P.UINT bits) = "u" ^ Int.toString bits
55    | numkindName (P.FLOAT bits) = "f" ^ Int.toString bits        | numkindToString (P.FLOAT bits) = "f" ^ Int.toString bits
56    
57  fun lookerName P.! = "!"      fun arithopToString P.ADD = "+"
58    | lookerName P.gethdlr = "gethdlr"        | arithopToString P.SUB = "-"
59    | lookerName P.subscript = "subscript"        | arithopToString P.MUL = "*"
60    | lookerName (P.numsubscript{kind}) = ("numsubscript" ^ numkindName kind)        | arithopToString P.DIV = "div"
61    | lookerName P.getvar = "getvar"        | arithopToString P.MOD = "mod"
62    | lookerName P.getspecial = "getspecial"        | arithopToString P.QUOT = "quot"
63    | lookerName (P.rawload {kind}) = ("rawload" ^ numkindName kind)        | arithopToString P.REM = "rem"
64          | arithopToString P.FDIV = "/"
65  fun branchName P.boxed = "boxed"        | arithopToString P.NEG = "~"
66    | branchName P.unboxed = "unboxed"        | arithopToString P.ABS = "abs"
67    | branchName (P.cmp{oper, kind}) =        | arithopToString P.FSQRT = "fsqrt"
68      (numkindName kind ^        | arithopToString P.FSIN = "sin"
69       (case oper        | arithopToString P.FCOS = "cos"
70        of P.GT   => ">"        | arithopToString P.FTAN = "tan"
71         | P.LT   => "<"        | arithopToString P.RSHIFT = "rshift"
72         | P.GTE  => ">="        | arithopToString P.RSHIFTL = "rshiftl"
73         | P.LTE  => "<="        | arithopToString P.LSHIFT = "lshift"
74         | P.EQL => "="        | arithopToString P.ANDB = "andb"
75         | P.NEQ => "<>"        | arithopToString P.ORB = "orb"
76        (*esac*)))        | arithopToString P.XORB = "xorb"
77    | branchName(P.fcmp{oper, size}) =        | arithopToString P.NOTB = "notb"
78      (numkindName (P.FLOAT size) ^  
79       (case oper      fun cmpopToString P.GT = ">"
80        of P.fEQ   => "="        | cmpopToString P.LT = "<"
81         | P.fULG  => "?<>"        | cmpopToString P.GTE = ">="
82         | P.fGT   => ">"        | cmpopToString P.LTE = "<="
83         | P.fGE   => ">="        | cmpopToString P.EQL = "="
84         | P.fLT   => "<"        | cmpopToString P.NEQ = "<>"
85         | P.fLE   => "<="  
86         | P.fLG   => "<>"      fun fcmpopToString P.F_EQ   = "="
87         | P.fLEG  => "<=>"        | fcmpopToString P.F_ULG = "?<>"
88         | P.fUGT  => "?>"        | fcmpopToString P.F_GT = ">"
89         | P.fUGE  => "?>="        | fcmpopToString P.F_GE = ">="
90         | P.fULT  => "?<"        | fcmpopToString P.F_LT = "<"
91         | P.fULE  => "?<="        | fcmpopToString P.F_LE = "<="
92         | P.fUE   => "?="        | fcmpopToString P.F_LG = "<>"
93         | P.fUN   => "?"        | fcmpopToString P.F_LEG = "<="
94             | P.fsgn  => "sgn"        | fcmpopToString P.F_UGT = "?>"
95       (*esac*)))        | fcmpopToString P.F_UGE = "?>="
96    | branchName P.pneq = "pneq"        | fcmpopToString P.F_ULT = "?<"
97    | branchName P.peql = "peql"        | fcmpopToString P.F_ULE = "?<="
98    | branchName P.streq = "streq"        | fcmpopToString P.F_UE = "?="
99    | branchName P.strneq = "strneq"        | fcmpopToString P.F_UN = "?"
100          | fcmpopToString P.F_SGN = "sgn"
101  fun setterName P.unboxedupdate = "unboxedupdate"  
102    | setterName P.update = "update"      fun branchToString P.BOXED = "boxed"
103    | setterName (P.numupdate{kind}) = ("numupdate" ^ numkindName kind)        | branchToString P.UNBOXED = "unboxed"
104    | setterName P.unboxedassign = "unboxedassign"        | branchToString (P.CMP{oper, kind}) = numkindToString kind ^ cmpopToString oper
105    | setterName P.assign = "assign"        | branchToString (P.FCMP{oper, size}) = numkindToString (P.FLOAT size) ^ fcmpopToString oper
106    | setterName P.sethdlr = "sethdlr"        | branchToString P.PEQL = "peql"
107    | setterName P.setvar = "setvar"        | branchToString P.PNEQ = "pneq"
108    | setterName P.setspecial = "setspecial"        | branchToString P.STREQL = "streql"
109    | setterName (P.rawstore {kind}) = ("rawstore" ^ numkindName kind)        | branchToString P.STRNEQ = "strneq"
110    | setterName (P.rawupdate cty) = ("rawupdate" ^ U.ctyToString cty)  
111        fun setterToString P.UNBOXEDUPDATE = "unboxedupdate"
112          | setterToString P.UPDATE = "update"
113          | setterToString (P.NUMUPDATE{kind}) = ("numupdate" ^ numkindToString kind)
114          | setterToString P.UNBOXEDASSIGN = "unboxedassign"
115          | setterToString P.ASSIGN = "assign"
116          | setterToString P.SETHDLR = "sethdlr"
117          | setterToString P.SETVAR = "setvar"
118          | setterToString P.SETSPECIAL = "setspecial"
119          | setterToString (P.RAWSTORE{kind}) = ("rawstore" ^ numkindToString kind)
120          | setterToString (P.RAWUPDATE cty) = ("rawupdate" ^ U.ctyToString cty)
121    
122        fun lookerToString P.DEREF = "!"
123          | lookerToString P.GETHDLR = "gethdlr"
124          | lookerToString P.SUBSCRIPT = "subscript"
125          | lookerToString (P.NUMSUBSCRIPT{kind}) = ("numsubscript" ^ numkindToString kind)
126          | lookerToString P.GETVAR = "getvar"
127          | lookerToString P.GETSPECIAL = "getspecial"
128          | lookerToString (P.RAWLOAD{kind}) = ("rawload" ^ numkindToString kind)
129    
130  val cvtParam = Int.toString  val cvtParam = Int.toString
131  fun cvtParams(from, to) = concat [cvtParam from, "_", cvtParam to]      fun cvtParams (prefix, from, to) = concat [prefix, cvtParam from, "_", cvtParam to]
132    
133        fun arithToString (P.ARITH{oper, kind}) = arithopToString oper ^ numkindToString kind
134          | arithToString (P.TEST{from, to}) = cvtParams ("test_", from, to)
135          | arithToString (P.TESTU{from, to}) = cvtParams ("testu_", from, to)
136          | arithToString (P.TEST_INF i) = "test_inf_" ^ cvtParam i
137          | arithToString (P.ROUND{floor, from, to}) = concat[
138                if floor then "floor" else "round",
139                numkindToString from, "to", numkindToString to
140              ]
141    
142  fun arithName (P.arith{oper,kind}) =      fun pureToString P.LENGTH = "length"
143      ((case oper of  P.ADD => "+" |  P.SUB => "-" |  P.MUL => "*"        | pureToString (P.PURE_ARITH{oper,kind}) = arithopToString oper ^ numkindToString kind
144                    | P.DIV => "div" | P.MOD => "mod"        | pureToString P.OBJLENGTH = "objlength"
145                    | P.QUOT => "quot" | P.REM => "rem"        | pureToString P.MAKEREF = "makeref"
146                    | P.FDIV => "/"        | pureToString (P.EXTEND{from, to}) = cvtParams ("extend_", from, to)
147                    | P.NEG => "~" | P.ABS => "abs"        | pureToString (P.COPY{from, to}) = cvtParams ("copy_", from, to)
148                    | P.FSQRT => "fsqrt"        | pureToString (P.TRUNC{from, to}) = cvtParams ("trunc_", from, to)
149                    | P.FSIN => "sin" | P.FCOS => "cos" | P.FTAN => "tan"        | pureToString (P.TRUNC_INF i) = "trunc_inf_" ^ cvtParam i
150                    | P.RSHIFT => "rshift" | P.RSHIFTL => "rshiftl"        | pureToString (P.COPY_INF i) = concat ["copy_", cvtParam i, "_inf"]
151                    | P.LSHIFT => "lshift" | P.ANDB => "andb"        | pureToString (P.EXTEND_INF i) =  concat ["extend_", cvtParam i, "_inf"]
152                    | P.ORB => "orb" | P.XORB => "xorb" | P.NOTB => "notb")        | pureToString (P.REAL{from, to}) =
153       ^ numkindName kind)            concat ["real", numkindToString from, "_", numkindToString to]
154    | arithName(P.test arg) = "test_" ^ cvtParams arg        | pureToString P.SUBSCRIPTV = "subscriptv"
155    | arithName(P.testu arg) = "testu_" ^ cvtParams arg        | pureToString (P.PURE_NUMSUBSCRIPT{kind}) = "numsubscriptv" ^ numkindToString kind
156    | arithName(P.test_inf i) = "test_inf_" ^ cvtParam i        | pureToString P.GETTAG = "gettag"
157    | arithName (P.round{floor=true,fromkind=P.FLOAT 64,tokind=P.INT 31}) =        | pureToString P.MKSPECIAL = "mkspecial"
158        "floor"        | pureToString P.CAST = "cast"
159    | arithName (P.round{floor=false,fromkind=P.FLOAT 64,tokind=P.INT 31}) =        | pureToString P.GETCON = "getcon"
160        "round"        | pureToString P.GETEXN = "getexn"
161    | arithName (P.round{floor,fromkind,tokind}) =        | pureToString P.BOX = "box"
162        ((if floor then "floor" else "round")        | pureToString P.UNBOX = "unbox"
163         ^ numkindName fromkind ^ "_" ^ numkindName tokind)        | pureToString (P.WRAP kind) = "wrap_" ^ numkindToString kind
164          | pureToString (P.UNWRAP kind) = "unwrap_" ^ numkindToString kind
165  fun pureName P.length = "length"        | pureToString P.GETSEQDATA = "getseqdata"
166    | pureName (P.pure_arith x) = arithName(P.arith x)        | pureToString P.RECSUBSCRIPT = "recsubscript"
167    | pureName P.objlength = "objlength"        | pureToString P.RAW64SUBSCRIPT = "raw64subscript"
168    | pureName P.makeref = "makeref"        | pureToString P.NEWARRAY0 = "newarray0"
169    | pureName (P.extend arg) = "extend_" ^ cvtParams arg        | pureToString (P.RAWRECORD rk) = "rawrecord_"^getOpt(Option.map rkstring rk, "notag")
   | pureName (P.copy arg) = "copy_" ^ cvtParams arg  
   | pureName (P.trunc arg) = "trunc_" ^ cvtParams arg  
   | pureName (P.trunc_inf i) = "trunc_inf_" ^ cvtParam i  
   | pureName (P.copy_inf i) = concat ["copy_", cvtParam i, "_inf"]  
   | pureName (P.extend_inf i) =  concat ["extend_", cvtParam i, "_inf"]  
   | pureName (P.real{fromkind=P.FLOAT 64,tokind=P.INT 31}) = "real"  
   | pureName (P.real{fromkind,tokind}) =  
       concat ["real", numkindName fromkind, "_", numkindName tokind]  
   | pureName P.subscriptv = "subscriptv"  
   | pureName (P.pure_numsubscript{kind}) = ("numsubscriptv" ^ numkindName kind)  
   | pureName P.gettag = "gettag"  
   | pureName P.mkspecial = "mkspecial"  
   | pureName P.cast = "cast"  
   | pureName P.getcon = "getcon"  
   | pureName P.getexn = "getexn"  
   | pureName P.box = "box"  
   | pureName P.unbox = "unbox"  
   | pureName (P.wrap kind) = "wrap_" ^ numkindName kind  
   | pureName (P.unwrap kind) = "unwrap_" ^ numkindName kind  
   | pureName P.getseqdata = "getseqdata"  
   | pureName P.recsubscript = "recsubscript"  
   | pureName P.raw64subscript = "raw64subscript"  
   | pureName P.newarray0 = "newarray0"  
   | pureName (P.rawrecord rk) = "rawrecord_"^getOpt(Option.map rkstring rk, "notag")  
170    
171  and rkstring rk = (case rk  and rkstring rk = (case rk
172         of RK_VECTOR => "RK_VECTOR"         of RK_VECTOR => "RK_VECTOR"
# Line 169  Line 182 
182          | RK_I32BLOCK => "RK_I32BLOCK"          | RK_I32BLOCK => "RK_I32BLOCK"
183        (* end case *))        (* end case *))
184    
185  fun show0 say =      fun show0 say = let
186    let fun sayc (#"\n") = say "\\n"            fun sayc (#"\n") = say "\\n"
187          | sayc c = say(String.str c)          | sayc c = say(String.str c)
188    
189        fun sayv v = say(value2str v)        fun sayv v = say(value2str v)
# Line 181  Line 194 
194    
195        fun sayrk(RK_RECORD,n) = ()        fun sayrk(RK_RECORD,n) = ()
196          | sayrk(RK_VECTOR,n) = ()          | sayrk(RK_VECTOR,n) = ()
197          | sayrk(k,n : int) = (say (rkstring k); say " ";              | sayrk (k, n) = (say (rkstring k); say " "; say (Int.toString n); say ",")
                               say (Int.toString n); say ",")  
198    
199        fun sayparam ([v],[ct]) = (sayv v; sayt ct)        fun sayparam ([v],[ct]) = (sayv v; sayt ct)
200          | sayparam (nil,nil) = ()          | sayparam (nil,nil) = ()
# Line 195  Line 207 
207        fun sayvp (v,path) = (sayv v; saypath path)        fun sayvp (v,path) = (sayv v; saypath path)
208        fun saylist f [x] = f x | saylist f nil = ()        fun saylist f [x] = f x | saylist f nil = ()
209          | saylist f (x::r) = (f x; say ","; saylist f r)          | saylist f (x::r) = (f x; say ","; saylist f r)
210        fun indent n =            fun indent n = let
211          let fun space 0 = () | space k = (say " "; space(k-1))                  fun space 0 = () | space k = (say " "; space(k-1))
212              fun nl() = say "\n"              fun nl() = say "\n"
213              val rec f =                  fun f (RECORD(k,vl,v,c)) = (
              fn RECORD(k,vl,v,c) => (  
214                    space n;                    space n;
215                    case k of RK_VECTOR => say "#{" | _ => say "{";                    case k of RK_VECTOR => say "#{" | _ => say "{";
216                    sayrk(k,length vl);                    sayrk(k,length vl);
217                    saylist sayvp vl; say "} -> ";                    saylist sayvp vl; say "} -> ";
218                    sayv(VAR v);                    sayv(VAR v);
219                    nl(); f c)                    nl(); f c)
220                | SELECT(i,v,w,t,c) =>                    | f (SELECT(i,v,w,t,c)) = (
221                      (space n; sayv v; say "."; say(Int.toString i); say " -> ";                          space n; sayv v; say "."; say(Int.toString i); say " -> ";
222                       sayv(VAR w); sayt(t); nl(); f c)                       sayv(VAR w); sayt(t); nl(); f c)
223                | OFFSET(i,v,w,c) =>                    | f (OFFSET(i,v,w,c)) = (
224                      (space n; sayv v; say "+"; say(Int.toString i); say " -> ";                          space n; sayv v; say "+"; say(Int.toString i); say " -> ";
225                      sayv(VAR w); nl(); f c)                      sayv(VAR w); nl(); f c)
226                | APP(w,vl) =>                    | f (APP(w,vl)) = (
227                      (space n; sayv w; say "("; sayvlist vl; say ")\n")                          space n; sayv w; say "("; sayvlist vl; say ")\n")
228                | FIX(bl,c) =>                    | f (FIX(bl,c)) = let
229                      let fun g(_,v,wl,cl,d) =                          fun g (_,v,wl,cl,d) = (
230                              (space n; sayv(VAR v); say "(";                                  space n; sayv(VAR v); say "(";
231                               sayparam (map VAR wl,cl);                               sayparam (map VAR wl,cl);
232                               say ") =\n";                               say ") =\n";
233                               indent (n+3) d)                               indent (n+3) d)
234                       in app g bl; f c                          in
235                              app g bl; f c
236                      end                      end
237                | SWITCH(v,c,cl) =>                    | f (SWITCH(v,c,cl)) = let
238                     let fun g(i,c::cl) =                          fun g (i,c::cl) = (
239                          (space(n+1); say(Int.toString(i:int));                                space(n+1); say(Int.toString(i:int));
240                           say " =>\n"; indent (n+3) c; g(i+1,cl))                           say " =>\n"; indent (n+3) c; g(i+1,cl))
241                           | g(_,nil) = ()                           | g(_,nil) = ()
242                      in space n; say "case "; sayv v; say "  [";                          in
243                              space n; say "case "; sayv v; say "  [";
244                         say(Int.toString(c));                         say(Int.toString(c));
245                         say "] of\n";                         say "] of\n";
246                         g(0,cl)                         g(0,cl)
247                     end                     end
248                | LOOKER(i,vl,w,t,e) =>                    | f (LOOKER(i,vl,w,t,e)) = (
249                     (space n; say(lookerName i); say "("; sayvlist vl;                          space n; say(lookerToString i); say "("; sayvlist vl;
250                      say ") -> "; sayv(VAR w); sayt(t); nl(); f e)                      say ") -> "; sayv(VAR w); sayt(t); nl(); f e)
251                | ARITH(i,vl,w,t,e) =>                    | f (ARITH(i,vl,w,t,e)) = (
252                     (space n; say(arithName i); say "("; sayvlist vl;                          space n; say(arithToString i); say "("; sayvlist vl;
253                      say ") -> "; sayv(VAR w); sayt(t); nl(); f e)                      say ") -> "; sayv(VAR w); sayt(t); nl(); f e)
254                | PURE(i,vl,w,t,e) =>                    | f (PURE(i,vl,w,t,e)) = (
255                     (space n; say(pureName i); say "("; sayvlist vl;                          space n; say(pureToString i); say "("; sayvlist vl;
256                      say ") -> "; sayv(VAR w); sayt(t); nl(); f e)                      say ") -> "; sayv(VAR w); sayt(t); nl(); f e)
257                | SETTER(i,vl,e) =>                    | f (SETTER(i,vl,e)) = (
258                     (space n; say(setterName i); say "("; sayvlist vl;                          space n; say(setterToString i); say "("; sayvlist vl;
259                      say ")"; nl(); f e)                      say ")"; nl(); f e)
260                | BRANCH(i,vl,c,e1,e2) =>                    | f (BRANCH(i,vl,c,e1,e2)) = (
261                     (space n; say "if "; say(branchName i);                          space n; say "if "; say(branchToString i);
262                           say "("; sayvlist vl; say ") [";                           say "("; sayvlist vl; say ") [";
263                           sayv(VAR c); say "] then\n";                           sayv(VAR c); say "] then\n";
264                      indent (n+3) e1;                      indent (n+3) e1;
265                      space n; say "else\n";                      space n; say "else\n";
266                      indent (n+3) e2)                      indent (n+3) e2)
267                | RCC(k,l,p,vl,wtl,e) =>                    | f (RCC(k,l,p,vl,wtl,e)) = (
268                     (space n;                          space n;
269                      if k = REENTRANT_RCC then say "reentrant " else ();                      if k = REENTRANT_RCC then say "reentrant " else ();
270                      if l = "" then () else (say l; say " ");                      if l = "" then () else (say l; say " ");
271                      say "rcc("; sayvlist vl; say ") -> ";                      say "rcc("; sayvlist vl; say ") -> ";
272                      app (fn (w, t) => (sayv (VAR w); sayt(t))) wtl;                      app (fn (w, t) => (sayv (VAR w); sayt(t))) wtl;
273                      nl(); f e)                      nl(); f e)
274           in f                  in
275          end                    f
  in  indent  
276   end   end
277              in
278                indent
279              end (* show0 *)
280    
281  fun printcps((_,f,vl,cl,e),m)=      fun printcps((_,f,vl,cl,e),m) = let
282  let fun ptv(v,t) = (say(LV.lvarName v); say " type ===>>>";            fun ptv(v,t) = (say(LV.lvarName v); say " type ===>>>";
283                      say(LtyExtern.lt_print t); say "\n")                      say(LtyExtern.lt_print t); say "\n")
   
284      val _ = if (!Control.CG.debugRep)      val _ = if (!Control.CG.debugRep)
285              then (say "************************************************\n";              then (say "************************************************\n";
286                    IntHashTable.appi ptv m;                    IntHashTable.appi ptv m;
287                    say "************************************************\n")                    say "************************************************\n")
288              else ()              else ()
   
289      fun sayv(v) = say(LV.lvarName v)      fun sayv(v) = say(LV.lvarName v)
290      fun sayparam ([v],[ct]) = (sayv v; sayt ct)      fun sayparam ([v],[ct]) = (sayv v; sayt ct)
291        | sayparam (nil,nil) = ()        | sayparam (nil,nil) = ()
# Line 280  Line 293 
293        | sayparam _ = ErrorMsg.impossible "sayparam in ppcps.sml 3435"        | sayparam _ = ErrorMsg.impossible "sayparam in ppcps.sml 3435"
294    
295   in   in
296      (say(LV.lvarName f); say "("; sayparam(vl,cl); say ") =\n";              say(LV.lvarName f); say "("; sayparam(vl,cl); say ") =\n";
297       show0 say 3 e)              show0 say 3 e
298  end  end
299    
300  exception NULLTABLE  exception NULLTABLE
# Line 292  Line 305 
305    
306  fun prcps(ce) = show0 (Control.Print.say) 1 ce  fun prcps(ce) = show0 (Control.Print.say) 1 ce
307    
 end (* toplevel local *)  
308  end (* structure PPCps *)  end (* structure PPCps *)
   

Legend:
Removed from v.4953  
changed lines
  Added in v.4960

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