asmcomp/printcmm.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id$ *)
  14
  15 (* Pretty-printing of C-- code *)
  16
  17 open Format
  18 open Cmm
  19
  20 let machtype_component ppf = function
  21   | Addr -> fprintf ppf "addr"
  22   | Int -> fprintf ppf "int"
  23   | Float -> fprintf ppf "float"
  24
  25 let machtype ppf mty =
  26   match Array.length mty with
  27   | 0 -> fprintf ppf "unit"
  28   | n -> machtype_component ppf mty.(0);
  29          for i = 1 to n-1 do
  30            fprintf ppf "*%a" machtype_component mty.(i)
  31          done
  32
  33 let comparison = function
  34   | Ceq -> "=="
  35   | Cne -> "!="
  36   | Clt -> "<"
  37   | Cle -> "<="
  38   | Cgt -> ">"
  39   | Cge -> ">="
  40
  41 let chunk = function
  42   | Byte_unsigned -> "unsigned int8"
  43   | Byte_signed -> "signed int8"
  44   | Sixteen_unsigned -> "unsigned int16"
  45   | Sixteen_signed -> "signed int16"
  46   | Thirtytwo_unsigned -> "unsigned int32"
  47   | Thirtytwo_signed -> "signed int32"
  48   | Word -> ""
  49   | Single -> "float32"
  50   | Double -> "float64"
  51   | Double_u -> "float64u"
  52
  53 let operation = function
  54   | Capply(ty, d) -> "app" ^ Debuginfo.to_string d
  55   | Cextcall(lbl, ty, alloc, d) ->
  56       Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d)
  57   | Cload Word -> "load"
  58   | Cload c -> Printf.sprintf "load %s" (chunk c)
  59   | Calloc -> "alloc"
  60   | Cstore Word -> "store"
  61   | Cstore c -> Printf.sprintf "store %s" (chunk c)
  62   | Caddi -> "+"
  63   | Csubi -> "-"
  64   | Cmuli -> "*"
  65   | Cdivi -> "/"
  66   | Cmodi -> "mod"
  67   | Cand -> "and"
  68   | Cor -> "or"
  69   | Cxor -> "xor"
  70   | Clsl -> "<<"
  71   | Clsr -> ">>u"
  72   | Casr -> ">>s"
  73   | Ccmpi c -> comparison c
  74   | Cadda -> "+a"
  75   | Csuba -> "-a"
  76   | Ccmpa c -> Printf.sprintf "%sa" (comparison c)
  77   | Cnegf -> "~f"
  78   | Cabsf -> "absf"
  79   | Caddf -> "+f"
  80   | Csubf -> "-f"
  81   | Cmulf -> "*f"
  82   | Cdivf -> "/f"
  83   | Cfloatofint -> "floatofint"
  84   | Cintoffloat -> "intoffloat"
  85   | Ccmpf c -> Printf.sprintf "%sf" (comparison c)
  86   | Craise d -> "raise" ^ Debuginfo.to_string d
  87   | Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d
  88
  89 let rec expr ppf = function
  90   | Cconst_int n -> fprintf ppf "%i" n
  91   | Cconst_natint n -> fprintf ppf "%s" (Nativeint.to_string n)
  92   | Cconst_float s -> fprintf ppf "%s" s
  93   | Cconst_symbol s -> fprintf ppf "\"%s\"" s
  94   | Cconst_pointer n -> fprintf ppf "%ia" n
  95   | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n)
  96   | Cvar id -> Ident.print ppf id
  97   | Clet(id, def, (Clet(_, _, _) as body)) ->
  98       let print_binding id ppf def =
  99         fprintf ppf "@[<2>%a@ %a@]" Ident.print id expr def in
 100       let rec in_part ppf = function
 101         | Clet(id, def, body) ->
 102             fprintf ppf "@ %a" (print_binding id) def;
 103             in_part ppf body
 104         | exp -> exp in
 105       fprintf ppf "@[<2>(let@ @[<1>(%a" (print_binding id) def;
 106       let exp = in_part ppf body in
 107       fprintf ppf ")@]@ %a)@]" sequence exp
 108   | Clet(id, def, body) ->
 109      fprintf ppf
 110       "@[<2>(let@ @[<2>%a@ %a@]@ %a)@]"
 111       Ident.print id expr def sequence body
 112   | Cassign(id, exp) ->
 113       fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" Ident.print id expr exp
 114   | Ctuple el ->
 115       let tuple ppf el =
 116        let first = ref true in
 117        List.iter
 118         (fun e ->
 119           if !first then first := false else fprintf ppf "@ ";
 120           expr ppf e)
 121         el in
 122       fprintf ppf "@[<1>[%a]@]" tuple el
 123   | Cop(op, el) ->
 124       fprintf ppf "@[<2>(%s" (operation op);
 125       List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
 126       begin match op with
 127       | Capply (mty, _) -> fprintf ppf "@ %a" machtype mty
 128       | Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty
 129       | _ -> ()
 130       end;
 131       fprintf ppf ")@]"
 132   | Csequence(e1, e2) ->
 133       fprintf ppf "@[<2>(seq@ %a@ %a)@]" sequence e1 sequence e2
 134   | Cifthenelse(e1, e2, e3) ->
 135       fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" expr e1 expr e2 expr e3
 136   | Cswitch(e1, index, cases) ->
 137       let print_case i ppf =
 138         for j = 0 to Array.length index - 1 do
 139           if index.(j) = i then fprintf ppf "case %i:" j
 140         done in
 141       let print_cases ppf =
 142        for i = 0 to Array.length cases - 1 do
 143         fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i)
 144        done in
 145       fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases
 146   | Cloop e ->
 147       fprintf ppf "@[<2>(loop@ %a)@]" sequence e
 148   | Ccatch(i, ids, e1, e2) ->
 149       fprintf ppf
 150         "@[<2>(catch@ %a@;<1 -2>with(%d%a)@ %a)@]"
 151         sequence e1 i
 152         (fun ppf ids ->
 153           List.iter
 154             (fun id -> fprintf ppf " %a" Ident.print id)
 155             ids) ids
 156         sequence e2
 157   | Cexit (i, el) ->
 158       fprintf ppf "@[<2>(exit %d" i ;
 159       List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
 160       fprintf ppf ")@]"
 161   | Ctrywith(e1, id, e2) ->
 162       fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]"
 163              sequence e1 Ident.print id sequence e2
 164
 165 and sequence ppf = function
 166   | Csequence(e1, e2) -> fprintf ppf "%a@ %a" sequence e1 sequence e2
 167   | e -> expression ppf e
 168
 169 and expression ppf e = fprintf ppf "%a" expr e
 170
 171 let fundecl ppf f =
 172   let print_cases ppf cases =
 173     let first = ref true in
 174     List.iter
 175      (fun (id, ty) ->
 176        if !first then first := false else fprintf ppf "@ ";
 177        fprintf ppf "%a: %a" Ident.print id machtype ty)
 178      cases in
 179   fprintf ppf "@[<1>(function %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@."
 180          f.fun_name print_cases f.fun_args sequence f.fun_body
 181
 182 let data_item ppf = function
 183   | Cdefine_symbol s -> fprintf ppf "\"%s\":" s
 184   | Cdefine_label l -> fprintf ppf "L%i:" l
 185   | Cglobal_symbol s -> fprintf ppf "global \"%s\"" s
 186   | Cint8 n -> fprintf ppf "byte %i" n
 187   | Cint16 n -> fprintf ppf "int16 %i" n
 188   | Cint32 n -> fprintf ppf "int32 %s" (Nativeint.to_string n)
 189   | Cint n -> fprintf ppf "int %s" (Nativeint.to_string n)
 190   | Csingle f -> fprintf ppf "single %s" f
 191   | Cdouble f -> fprintf ppf "double %s" f
 192   | Csymbol_address s -> fprintf ppf "addr \"%s\"" s
 193   | Clabel_address l -> fprintf ppf "addr L%i" l
 194   | Cstring s -> fprintf ppf "string \"%s\"" s
 195   | Cskip n -> fprintf ppf "skip %i" n
 196   | Calign n -> fprintf ppf "align %i" n
 197
 198 let data ppf dl =
 199   let items ppf = List.iter (fun d -> fprintf ppf "@ %a" data_item d) dl in
 200   fprintf ppf "@[<hv 1>(data%t)@]" items
 201
 202 let phrase ppf = function
 203   | Cfunction f -> fundecl ppf f
 204   | Cdata dl -> data ppf dl