Commits

Anonymous committed dbcdb15

Premiere version.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@34f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

  • Participants
  • Parent commits 0373f5e

Comments (0)

Files changed (60)

+ARCH=sparc
+
+include ../Makefile.config
+
+CAMLC=cslc
+COMPFLAGS=$(INCLUDES)
+LINKFLAGS=
+CAMLYACC=cslyacc
+YACCFLAGS=
+CAMLLEX=csllex
+CAMLDEP=../tools/camldep
+DEPFLAGS=$(INCLUDES)
+CAMLRUN=cslrun
+
+INCLUDES=-I ../utils -I ../typing
+
+UTILS=../utils/misc.cmo ../utils/tbl.cmo ../typing/ident.cmo
+
+OBJS=arch.cmo cmm.cmo printcmm.cmo \
+  reg.cmo mach.cmo proc.cmo printmach.cmo \
+  selection.cmo sequence.cmo liveness.cmo spill.cmo split.cmo \
+  interf.cmo coloring.cmo reload.cmo linearize.cmo printlinear.cmo \
+  emitaux.cmo emit.cmo \
+  parsecmmaux.cmo parsecmm.cmo lexcmm.cmo \
+  codegen.cmo main.cmo
+
+codegen: $(OBJS)
+	$(CAMLC) $(LINKFLAGS) -o codegen $(UTILS) $(OBJS)
+clean::
+	rm -f codegen
+
+# Choose the right arch, emit and proc files
+
+arch.ml: arch_$(ARCH).ml
+	ln -s arch_$(ARCH).ml arch.ml
+clean::
+	rm -f arch.ml
+beforedepend:: arch.ml
+
+proc.ml: proc_$(ARCH).ml
+	ln -s proc_$(ARCH).ml proc.ml
+clean::
+	rm -f proc.ml
+beforedepend:: proc.ml
+
+# Preprocess the code emitters
+
+emit.ml: emit_$(ARCH).mlp ../tools/cvt_emit
+	../tools/cvt_emit emit_$(ARCH).mlp > emit.ml || rm -f emit.ml
+clean::
+	rm -f emit.ml
+
+beforedepend:: emit.ml
+
+# The parser
+
+parsecmm.mli parsecmm.ml: parsecmm.mly
+	$(CAMLYACC) $(YACCFLAGS) parsecmm.mly
+
+clean::
+	rm -f parsecmm.mli parsecmm.ml parsecmm.output
+
+beforedepend:: parsecmm.mli parsecmm.ml
+
+# The lexer
+
+lexcmm.ml: lexcmm.mll
+	$(CAMLLEX) lexcmm.mll
+
+clean::
+	rm -f lexcmm.ml
+
+beforedepend:: lexcmm.ml
+
+# Default rules
+
+.SUFFIXES: .ml .mli .cmo .cmi
+
+.ml.cmo:
+	$(CAMLC) $(COMPFLAGS) -c $<
+
+.mli.cmi:
+	$(CAMLC) $(COMPFLAGS) -c $<
+
+clean::
+	rm -f *.cm[io] *~
+
+depend: beforedepend
+	$(CAMLDEP) $(DEPFLAGS) *.mli *.ml > .depend
+
+include .depend
+#directory "../utils";;
+#directory "../typing";;
+#load "../utils/misc.cmo";;
+#load "../utils/tbl.cmo";;
+#load "../typing/ident.cmo";;
+#load "arch.cmo";;
+#load "cmm.cmo";;
+#load "printcmm.cmo";;
+#load "reg.cmo";;
+#load "mach.cmo";;
+#load "proc.cmo";;
+(*********
+#load "printmach.cmo";;
+#load "selection.cmo";;
+#load "sequence.cmo";;
+#load "liveness.cmo";;
+#load "spill.cmo";;
+#load "split.cmo";;
+#load "interf.cmo";;
+#load "coloring.cmo";;
+#load "reload.cmo";;
+#load "linearize.cmo";;
+#load "emitaux.cmo";;
+#load "emit.cmo";;
+#load "parsecmmaux.cmo";;
+#load "parsecmm.cmo";;
+#load "lexcmm.cmo";;
+#load "codegen.cmo";;
+***********)

asmcomp/arch_alpha.ml

+(* Specific operations for the Alpha processor *)
+
+open Format
+
+type specific_operation =
+   Iadd4 | Iadd8 | Isub4 | Isub8        (* Scaled adds and subs *)
+
+(* Addressing modes *)
+
+type addressing_mode =
+    Ibased of string * int              (* symbol + displ *)
+  | Iindexed of int                     (* reg + displ *)
+
+(* Sizes, endianness *)
+
+let big_endian = false
+
+let size_addr = 8
+let size_int = 8
+let size_float = 8
+
+(* Operations on addressing modes *)
+
+let identity_addressing = Iindexed 0
+
+let offset_addressing addr delta =
+  match addr with
+    Ibased(s, n) -> Ibased(s, n + delta)
+  | Iindexed n -> Iindexed(n + delta)
+
+let num_args_addressing = function
+    Ibased(s, n) -> 0
+  | Iindexed n -> 1
+
+(* Printing operations and addressing modes *)
+
+let print_addressing printreg addr arg =
+  match addr with
+    Ibased(s, n) ->
+      print_string "\""; print_string s; print_string "\"";
+      if n <> 0 then begin print_string " + "; print_int n end
+  | Iindexed n ->
+      printreg arg.(0);
+      if n <> 0 then begin print_string " + "; print_int n end
+
+let print_specific_operation printreg op arg =
+  match op with
+    Iadd4 -> printreg arg.(0); print_string " * 4 + "; printreg arg.(1)
+  | Iadd8 -> printreg arg.(0); print_string " * 8 + "; printreg arg.(1)
+  | Isub4 -> printreg arg.(0); print_string " * 4 - "; printreg arg.(1)
+  | Isub8 -> printreg arg.(0); print_string " * 8 - "; printreg arg.(1)
+

asmcomp/arch_i386.ml

+(* Specific operations for the Intel 386 processor *)
+
+type addressing_mode =
+    Ibased of string * int              (* symbol + displ *)
+  | Iindexed of int                     (* reg + displ *)
+  | Iindexed2 of int                    (* reg + reg + displ *)
+  | Iindexed2scaled of int * int        (* reg + reg * scale + displ *)
+
+type specific_operation =
+    Ineg                                (* Integer negate *)
+  | Ilea of addressing_mode             (* Lea gives scaled adds *)
+
+(* Sizes, endianness *)
+
+let big_endian = false
+
+let size_addr = 4
+let size_int = 4
+let size_float = 8
+
+(* Operations on addressing modes *)
+
+let identity_addressing = Iindexed 0
+
+let offset_addressing addr delta =
+  match addr with
+    Ibased(s, n) -> Ibased(s, n + delta)
+  | Iindexed n -> Iindexed(n + delta)
+  | Iindexed2 n -> Iindexed2(n + delta)
+  | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta)
+
+let num_args_addressing = function
+    Ibased(s, n) -> 0
+  | Iindexed n -> 1
+  | Iindexed2 n -> 2
+  | Iindexed2scaled(scale, n) -> 2
+
+(* Printing operations and addressing modes *)
+
+open Format
+
+let print_addressing printreg addr arg =
+  match addr with
+    Ibased(s, 0) ->
+      print_string "\""; print_string s; print_string "\""
+  | Ibased(s, n) ->
+      print_string "\""; print_string s; print_string "\" + "; print_int n
+  | Iindexed n ->
+      printreg arg.(0);
+      if n <> 0 then begin print_string " + "; print_int n end
+  | Iindexed2 n ->
+      printreg arg.(0); print_string " + "; printreg arg.(1);
+      if n <> 0 then begin print_string " + "; print_int n end
+  | Iindexed2scaled(scale, n) ->
+      printreg arg.(0); print_string " + "; printreg arg.(1);
+      print_string " * "; print_int scale;
+      if n <> 0 then begin print_string " + "; print_int n end
+
+let print_specific_operation printreg op arg =
+  match op with
+    Ineg -> print_string "- "; printreg arg.(0)
+  | Ilea addr -> print_addressing printreg addr arg
+

asmcomp/arch_sparc.ml

+(* Specific operations for the Sparc processor *)
+
+open Format
+
+type specific_operation = unit          (* None worth mentioning *)
+
+(* Addressing modes *)
+
+type addressing_mode =
+    Ibased of string * int              (* symbol + displ *)
+  | Iindexed of int                     (* reg + displ *)
+  | Iindexed2 of int                    (* reg + reg + displ *)
+
+(* Sizes, endianness *)
+
+let big_endian = true
+
+let size_addr = 4
+let size_int = 4
+let size_float = 8
+
+(* Operations on addressing modes *)
+
+let identity_addressing = Iindexed 0
+
+let offset_addressing addr delta =
+  match addr with
+    Ibased(s, n) -> Ibased(s, n + delta)
+  | Iindexed n -> Iindexed(n + delta)
+  | Iindexed2 n -> Iindexed2(n + delta)
+
+let num_args_addressing = function
+    Ibased(s, n) -> 0
+  | Iindexed n -> 1
+  | Iindexed2 n -> 2
+
+(* Printing operations and addressing modes *)
+
+let print_addressing printreg addr arg =
+  match addr with
+    Ibased(s, n) ->
+      print_string "\""; print_string s; print_string "\"";
+      if n <> 0 then begin print_string " + "; print_int n end
+  | Iindexed n ->
+      printreg arg.(0);
+      if n <> 0 then begin print_string " + "; print_int n end
+  | Iindexed2 n ->
+      printreg arg.(0); print_string " + "; printreg arg.(1);
+      if n <> 0 then begin print_string " + "; print_int n end
+
+let print_specific_operation printreg op arg =
+  Misc.fatal_error "Arch_sparc.print_specific_operation"
+type constant =
+    Const_int of int
+  | Const_float of string
+  | Const_symbol of string
+  | Const_pointer of int
+
+type machtype_component =
+    Addr
+  | Int
+  | Float
+
+type machtype = machtype_component array
+
+let typ_void = ([||] : machtype)
+let typ_addr = [|Addr|]
+let typ_int = [|Int|]
+let typ_float = [|Float|]
+
+let size_component = function
+    Addr -> Arch.size_addr
+  | Int -> Arch.size_int
+  | Float -> Arch.size_float
+
+let size_machtype mty =
+  let size = ref 0 in
+  for i = 0 to Array.length mty - 1 do
+    size := !size + size_component mty.(i)
+  done;
+  !size
+
+type comparison =
+    Ceq
+  | Cne
+  | Clt
+  | Cle
+  | Cgt
+  | Cge
+
+let negate_comparison = function
+    Ceq -> Cne | Cne -> Ceq
+  | Clt -> Cge | Cle -> Cgt
+  | Cgt -> Cle | Cge -> Clt
+
+let swap_comparison = function
+    Ceq -> Ceq | Cne -> Cne
+  | Clt -> Cgt | Cle -> Cge
+  | Cgt -> Clt | Cge -> Cle
+
+type memory_chunk =
+    Byte_unsigned
+  | Byte_signed
+  | Sixteen_unsigned
+  | Sixteen_signed
+  | Word
+
+type operation =
+    Capply of machtype
+  | Cextcall of string * machtype
+  | Cproj of int * int
+  | Cload of machtype
+  | Cloadchunk of memory_chunk
+  | Calloc
+  | Cstore
+  | Cstorechunk of memory_chunk
+  | Cmodify
+  | Caddi | Csubi | Cmuli | Cdivi | Cmodi
+  | Cand | Cor | Cxor | Clsl | Clsr | Casr
+  | Ccmpi of comparison
+  | Cadda | Csuba
+  | Ccmpa of comparison
+  | Caddf | Csubf | Cmulf | Cdivf
+  | Cfloatofint | Cintoffloat
+  | Ccmpf of comparison
+  | Craise
+
+type expression =
+    Cconst of constant
+  | Cvar of Ident.t
+  | Clet of Ident.t * expression * expression
+  | Cassign of Ident.t * expression
+  | Ctuple of expression list
+  | Cop of operation * expression list
+  | Csequence of expression * expression
+  | Cifthenelse of expression * expression * expression
+  | Cswitch of expression * int array * expression array
+  | Cwhile of expression * expression
+  | Ccatch of expression * expression
+  | Cexit
+  | Ctrywith of expression * Ident.t * expression
+
+type fundecl =
+  { fun_name: string;
+    fun_args: (Ident.t * machtype) list;
+    fun_body: expression }
+
+type data_item =
+    Clabel of string
+  | Cint8 of int
+  | Cint16 of int
+  | Cint of int
+  | Cfloat of string
+  | Caddress of string
+  | Cstring of string
+  | Cskip of int
+  | Calign of int
+
+type phrase =
+    Cfunction of fundecl
+  | Cdata of data_item list
+
+(* Second intermediate language (machine independent) *)
+
+type constant =
+    Const_int of int
+  | Const_float of string
+  | Const_symbol of string
+  | Const_pointer of int
+
+type machtype_component =
+    Addr
+  | Int
+  | Float
+
+type machtype = machtype_component array
+
+val typ_void: machtype
+val typ_addr: machtype
+val typ_int: machtype
+val typ_float: machtype
+
+val size_component: machtype_component -> int
+val size_machtype: machtype -> int
+
+type comparison =
+    Ceq
+  | Cne
+  | Clt
+  | Cle
+  | Cgt
+  | Cge
+
+val negate_comparison: comparison -> comparison
+val swap_comparison: comparison -> comparison
+
+type memory_chunk =
+    Byte_unsigned
+  | Byte_signed
+  | Sixteen_unsigned
+  | Sixteen_signed
+  | Word
+
+type operation =
+    Capply of machtype
+  | Cextcall of string * machtype
+  | Cproj of int * int
+  | Cload of machtype
+  | Cloadchunk of memory_chunk
+  | Calloc
+  | Cstore
+  | Cstorechunk of memory_chunk
+  | Cmodify
+  | Caddi | Csubi | Cmuli | Cdivi | Cmodi
+  | Cand | Cor | Cxor | Clsl | Clsr | Casr
+  | Ccmpi of comparison
+  | Cadda | Csuba
+  | Ccmpa of comparison
+  | Caddf | Csubf | Cmulf | Cdivf
+  | Cfloatofint | Cintoffloat
+  | Ccmpf of comparison
+  | Craise
+
+type expression =
+    Cconst of constant
+  | Cvar of Ident.t
+  | Clet of Ident.t * expression * expression
+  | Cassign of Ident.t * expression
+  | Ctuple of expression list
+  | Cop of operation * expression list
+  | Csequence of expression * expression
+  | Cifthenelse of expression * expression * expression
+  | Cswitch of expression * int array * expression array
+  | Cwhile of expression * expression
+  | Ccatch of expression * expression
+  | Cexit
+  | Ctrywith of expression * Ident.t * expression
+
+type fundecl =
+  { fun_name: string;
+    fun_args: (Ident.t * machtype) list;
+    fun_body: expression }
+
+type data_item =
+    Clabel of string
+  | Cint8 of int
+  | Cint16 of int
+  | Cint of int
+  | Cfloat of string
+  | Caddress of string
+  | Cstring of string
+  | Cskip of int
+  | Calign of int
+
+type phrase =
+    Cfunction of fundecl
+  | Cdata of data_item list
+

asmcomp/codegen.ml

+(* From C-- to assembly code *)
+
+open Format
+open Cmm
+
+let dump_cmm = ref false
+let dump_selection = ref false
+let dump_live = ref false
+let dump_spill = ref false
+let dump_split = ref false
+let dump_interf = ref false
+let dump_prefer = ref false
+let dump_regalloc = ref false
+let dump_reload = ref false
+let dump_linear = ref false
+
+let rec regalloc fd =
+  if !dump_live then Printmach.phase "Liveness analysis" fd;
+  Interf.build_graph fd;
+  if !dump_interf then Printmach.interferences();
+  if !dump_prefer then Printmach.preferences();
+  Coloring.allocate_registers();
+  if !dump_regalloc then
+    Printmach.phase "After register allocation" fd;
+  let (newfd, redo_regalloc) = Reload.fundecl fd in
+  if !dump_reload then
+    Printmach.phase "After insertion of reloading code" newfd;
+  if redo_regalloc 
+  then begin Reg.reinit(); Liveness.fundecl newfd; regalloc newfd end
+  else newfd
+
+let fundecl fd_cmm =
+  if !dump_cmm then begin
+    print_string "*** C-- code"; print_newline();
+    Printcmm.fundecl fd_cmm; print_newline()
+  end;
+  Reg.reset();
+  let fd_sel = Sequence.fundecl fd_cmm in
+  if !dump_selection then
+    Printmach.phase "After instruction selection" fd_sel;
+  Liveness.fundecl fd_sel;
+  if !dump_live then Printmach.phase "Liveness analysis" fd_sel;
+  let fd_spill = Spill.fundecl fd_sel in
+  Liveness.fundecl fd_spill;
+  if !dump_spill then
+    Printmach.phase "After spilling" fd_spill;
+  let fd_split = Split.fundecl fd_spill in
+  Liveness.fundecl fd_split;
+  if !dump_split then
+    Printmach.phase "After live range splitting" fd_split;
+  let fd_reload = regalloc fd_split in
+  let fd_linear = Linearize.fundecl fd_reload in
+  if !dump_linear then begin
+    print_string "*** Linearized code"; print_newline();
+    Printlinear.fundecl fd_linear; print_newline()
+  end;
+  Emit.fundecl fd_linear
+
+let phrase = function
+    Cfunction fd -> fundecl fd
+  | Cdata dl -> Emit.data dl
+
+let file filename =
+  let ic = open_in filename in
+  let lb = Lexing.from_channel ic in
+  try
+    while true do
+      phrase(Parsecmm.phrase Lexcmm.token lb)
+    done
+  with
+      End_of_file ->
+        close_in ic
+    | Lexcmm.Error msg ->
+        close_in ic; Lexcmm.report_error lb msg
+    | Parsing.Parse_error ->
+        close_in ic;
+        prerr_string "Syntax error near character ";
+        prerr_int (Lexing.lexeme_start lb);
+        prerr_newline()
+    | Parsecmmaux.Error msg ->
+        close_in ic; Parsecmmaux.report_error msg
+    | x ->
+        close_in ic; raise x
+
+        
+
+        

asmcomp/codegen.mli

+(* From C-- to assembly code *)
+
+val phrase: Cmm.phrase -> unit
+val file: string -> unit
+
+val dump_cmm: bool ref
+val dump_selection: bool ref
+val dump_live: bool ref
+val dump_spill: bool ref
+val dump_split: bool ref
+val dump_interf: bool ref
+val dump_prefer: bool ref
+val dump_regalloc: bool ref
+val dump_reload: bool ref
+val dump_linear: bool ref

asmcomp/coloring.ml

+(* Register allocation by coloring of the interference graph *)
+
+open Reg
+
+(* Compute the degree (= number of neighbours of the same type)
+   of each register, and split them in two sets:
+   unconstrained (degree < number of available registers)
+   and constrained (degree >= number of available registers) *)
+
+let unconstrained = ref Reg.Set.empty
+let constrained = ref Reg.Set.empty
+
+let find_degree reg =
+  let deg = ref 0 in
+  let class = Proc.register_class reg in
+  List.iter
+    (fun r -> if Proc.register_class r = class then incr deg)
+    reg.interf;
+  reg.degree <- !deg;
+  if !deg >= Proc.num_available_registers.(class)
+  then constrained := Reg.Set.add reg !constrained
+  else unconstrained := Reg.Set.add reg !unconstrained
+
+(* Remove a register from the interference graph *)
+
+let remove_reg reg =
+  reg.degree <- 0;   (* 0 means r is no longer part of the graph *)
+  let class = Proc.register_class reg in
+  List.iter
+    (fun r ->
+      if Proc.register_class r = class & r.degree > 0 then begin
+        let olddeg = r.degree in
+        r.degree <- olddeg - 1;
+        if olddeg = Proc.num_available_registers.(class) then begin
+          (* r was constrained and becomes unconstrained *)
+          constrained := Reg.Set.remove r !constrained;
+          unconstrained := Reg.Set.add r !unconstrained
+        end
+      end)
+    reg.interf
+
+(* Remove all registers one by one, unconstrained if possible, otherwise
+   constrained with lowest spill cost. Return the list of registers removed
+   in reverse order.
+   The spill cost measure is [r.spill_cost / r.degree].
+   [r.spill_cost] estimates the number of accesses to this register. *)
+
+let rec remove_all_regs stack =
+  if not (Reg.Set.is_empty !unconstrained) then begin
+    (* Pick any unconstrained register *)
+    let r = Reg.Set.choose !unconstrained in
+    unconstrained := Reg.Set.remove r !unconstrained;
+    remove_all_regs (r :: stack)
+  end else
+  if not (Reg.Set.is_empty !constrained) then begin
+    (* Find a constrained reg with minimal cost *)
+    let r = ref Reg.dummy in
+    let min_degree = ref 0 and min_spill_cost = ref 1 in
+      (* initially !min_spill_cost / !min_degree is +infty *)
+    Reg.Set.iter
+      (fun r2 ->
+        (* if r2.spill_cost / r2.degree < !min_spill_cost / !min_degree *)
+        if r2.spill_cost * !min_degree < !min_spill_cost * r2.degree
+        then begin
+          r := r2; min_degree := r2.degree; min_spill_cost := r2.spill_cost
+        end)
+      !constrained;
+    constrained := Reg.Set.remove !r !constrained;
+    remove_all_regs (!r :: stack)
+  end else
+    stack                             (* All regs have been removed *)
+
+(* Iterate over all registers preferred by the given register (transitively) *)
+
+let iter_preferred f reg =
+  let rec walk r w =
+    if not r.visited then begin
+      f r w;
+      begin match r.prefer with
+          [] -> ()
+        | p  -> r.visited <- true;
+                List.iter (fun (r1, w1) -> walk r1 (min w w1)) p;
+                r.visited <- false
+      end
+    end in
+  reg.visited <- true;
+  List.iter (fun (r, w) -> walk r w) reg.prefer;
+  reg.visited <- false
+
+(* Assign a location to a register, the best we can *)
+
+let assign_location reg =
+  let class = Proc.register_class reg in
+  let first_reg = Proc.first_available_register.(class) in
+  let num_regs = Proc.num_available_registers.(class) in
+  let last_reg = first_reg + num_regs in
+  let score = Array.new num_regs 0 in
+  (* Favor the registers that have been assigned to pseudoregs for which
+     we have a preference. If these pseudoregs have not been assigned
+     already, avoid the registers with which they conflict. *)
+  iter_preferred
+    (fun r w ->
+      match r.loc with
+        Reg n -> if n >= first_reg & n < last_reg then
+                   score.(n - first_reg) <- score.(n - first_reg) + w
+      | Unknown ->
+          List.iter
+            (fun neighbour ->
+              match neighbour.loc with
+                Reg n -> if n >= first_reg & n < last_reg then
+                         score.(n - first_reg) <- score.(n - first_reg) - w
+              | _ -> ())
+            r.interf
+      | _ -> ())
+    reg;
+  List.iter
+    (fun neighbour ->
+      (* Prohibit the registers that have been assigned
+         to our neighbours *)
+      begin match neighbour.loc with
+        Reg n -> if n >= first_reg & n < last_reg then
+                   score.(n - first_reg) <- (-1000000)
+      | _ -> ()
+      end;
+      (* Avoid the registers that have been assigned to pseudoregs
+         for which our neighbours have a preference *)
+      iter_preferred
+        (fun r w ->
+          match r.loc with
+            Reg n -> if n >= first_reg & n < last_reg then
+                       score.(n - first_reg) <- score.(n - first_reg) - w
+          | _ -> ())
+        neighbour)
+    reg.interf;
+  (* Pick the register with the best score *)
+  let best_score = ref (-1000000) and best_reg = ref (-1) in
+  for n = 0 to num_regs - 1 do
+    if score.(n) > !best_score then begin
+      best_score := score.(n);
+      best_reg := n
+    end
+  done;
+  (* Found a register? *)
+  if !best_reg >= 0 then
+    reg.loc <- Reg(first_reg + !best_reg)
+  else begin
+    (* Sorry, we must put the pseudoreg in a stack location *)
+    (* First, check if we have a preference for an incoming location
+       we do not conflict with. *)
+    let best_score = ref 0 and best_incoming_loc = ref (-1) in
+    List.iter
+      (fun (r, w) ->
+        match r.loc with
+          Stack(Incoming n) ->
+            if w > !best_score
+             & List.for_all (fun neighbour -> neighbour.loc <> r.loc)
+                            reg.interf
+            then begin
+              best_score := w;
+              best_incoming_loc := n
+            end
+        | _ -> ())
+      reg.prefer;
+    if !best_incoming_loc >= 0 then
+      reg.loc <- Stack(Incoming !best_incoming_loc)
+    else begin
+      (* Now, look for a location in the local area *)
+      let nslots = Proc.num_stack_slots.(class) in
+      let score = Array.new nslots 0 in
+      (* Compute the scores as for registers *)
+      List.iter
+        (fun (r, w) ->
+          match r.loc with
+            Stack(Local n) -> if Proc.register_class r = class then
+                              score.(n) <- score.(n) + w
+          | Unknown ->
+              List.iter
+                (fun neighbour ->
+                  match neighbour.loc with
+                    Stack(Local n) ->
+                      if Proc.register_class neighbour = class
+                      then score.(n) <- score.(n) - w
+                  | _ -> ())
+                r.interf
+          | _ -> ())
+        reg.prefer;
+      List.iter
+        (fun neighbour ->
+          begin match neighbour.loc with
+              Stack(Local n) ->
+                if Proc.register_class neighbour = class then
+                score.(n) <- (-1000000)
+          | _ -> ()
+          end;
+          List.iter
+            (fun (r, w) ->
+              match r.loc with
+                Stack(Local n) -> if Proc.register_class r = class then
+                                  score.(n) <- score.(n) - w
+              | _ -> ())
+            neighbour.prefer)
+        reg.interf;
+      (* Pick the location with the best score *)
+      let best_score = ref (-1000000) and best_slot = ref (-1) in
+      for n = 0 to nslots - 1 do
+        if score.(n) > !best_score then begin
+          best_score := score.(n);
+          best_slot := n
+        end
+      done;
+      (* Found one? *)
+      if !best_slot >= 0 then
+        reg.loc <- Stack(Local !best_slot)
+      else begin
+        (* Allocate a new stack slot *)
+        reg.loc <- Stack(Local nslots);
+        Proc.num_stack_slots.(class) <- nslots + 1
+      end
+    end
+  end;
+  (* Cancel the preferences of this register so that they don't influence
+     transitively the allocation of registers that prefer this reg. *)
+  reg.prefer <- []
+
+let allocate_registers() =
+  (* First pass: compute the degrees
+     Second pass: determine coloring order by successive removals of regs
+     Third pass: assign registers in that order *)
+  for i = 0 to Proc.num_register_classes - 1 do
+    Proc.num_stack_slots.(i) <- 0
+  done;
+  List.iter find_degree (Reg.all_registers());
+  List.iter assign_location (remove_all_regs [])

asmcomp/coloring.mli

+(* Register allocation by coloring of the interference graph *)
+
+val allocate_registers: unit -> unit
+(* Generation of assembly code *)
+
+val fundecl: Linearize.fundecl -> unit
+val data: Cmm.data_item list -> unit
+val begin_assembly: unit -> unit
+val end_assembly: unit -> unit
+val fastcode_flag: bool ref

asmcomp/emit_alpha.mlp

+(* Emission of Alpha assembly code *)
+
+open Misc
+open Cmm
+open Arch
+open Proc
+open Reg
+open Mach
+open Linearize
+open Emitaux
+
+(* Tradeoff between code size and code speed *)
+
+let fastcode_flag = ref true
+
+(* Output a label *)
+
+let emit_label lbl =
+  emit_string "$"; emit_int lbl
+
+(* Output a pseudo-register *)
+
+let emit_reg r =
+  match r.loc with
+    Reg r -> emit_string (register_name r)
+  | _ -> fatal_error "Emit_alpha.emit_reg"
+
+(* Output a stack reference *)
+
+let emit_stack r =
+  match r.loc with
+    Stack s ->
+      let ofs = slot_offset s (register_class r) in `{emit_int ofs}($sp)`
+  | _ -> fatal_error "Emit_alpha.emit_stack"
+
+(* Output an addressing mode *)
+
+let emit_addressing addr r n =
+  match addr with
+    Iindexed ofs ->
+      `{emit_int ofs}({emit_reg r.(n)})`
+  | Ibased(s, 0) ->
+      `{emit_symbol s}`
+  | Ibased(s, ofs) ->
+      `{emit_symbol s} + {emit_int ofs}`
+
+(* Record live pointers at call points *)
+
+type frame_descr =
+  { fd_lbl: int;                        (* Return address *)
+    fd_frame_size: int;                 (* Size of stack frame *)
+    fd_live_offset: int list }          (* Offsets/regs of live addresses *)
+
+let frame_descriptors = ref([] : frame_descr list)
+
+let record_frame_label live =
+  let lbl = new_label() in
+  let live_offset = ref [] in
+  Reg.Set.iter
+    (function
+        {typ = Addr; loc = Reg r} ->
+          live_offset := (-1 - r) :: !live_offset
+      | {typ = Addr; loc = Stack s} as reg ->
+          live_offset := slot_offset s (register_class reg) :: !live_offset
+      | _ -> ())
+    live;
+  frame_descriptors :=
+    { fd_lbl = lbl;
+      fd_frame_size = frame_size();
+      fd_live_offset = !live_offset } :: !frame_descriptors;
+  lbl
+
+let record_frame live =
+  let lbl = record_frame_label live in `{emit_label lbl}:`
+
+let emit_frame fd =
+  `	.quad	{emit_label fd.fd_lbl} + 4\n`;
+  `	.half	{emit_int fd.fd_frame_size}\n`;
+  `	.half	{emit_int (List.length fd.fd_live_offset)}\n`;
+  List.iter
+    (fun n ->
+      `	.half	{emit_int n}\n`)
+    fd.fd_live_offset;
+  `	.align	3\n`
+
+(* Communicate live registers at call points to the assembler *)
+
+let int_reg_number = [|
+  (* 0-8 *)    0; 1; 2; 3; 4; 5; 6; 7; 8;
+  (* 9-12 *)   9; 10; 11; 12;
+  (* 13-18 *)  16; 17; 18; 19; 20; 21;
+  (* 19-20 *)  22; 23
+|]
+  
+let float_reg_number = [|
+  (* 100-107 *) 0; 1; 10; 11; 12; 13; 14; 15;
+  (* 108-115 *) 2; 3; 4; 5; 6; 7; 8; 9;
+  (* 116-121 *) 16; 17; 18; 19; 20; 21;
+  (* 122-127 *) 22; 23; 24; 25; 26; 27;
+  (* 128-129 *) 28; 29
+|]
+
+let liveregs instr extra_msk =
+  (* $13, $14, $15, $26 always live *)
+  let int_mask = ref(0x00070020 lor extra_msk)
+  and float_mask = ref 0 in
+  let add_register = function
+      {loc = Reg r; typ = (Int | Addr)} ->
+        int_mask := !int_mask lor (1 lsl (31 - int_reg_number.(r)))
+    | {loc = Reg r; typ = Float} ->
+        float_mask := !float_mask lor (1 lsl (31 - float_reg_number.(r - 100)))
+    | _ -> () in
+  Reg.Set.iter add_register instr.live;
+  Array.iter add_register instr.arg;
+  emit_printf "	.livereg 0x%08x, 0x%08x\n" !int_mask !float_mask
+
+let live_24 = 1 lsl (31 - 24)
+let live_25 = 1 lsl (31 - 25)
+let live_27 = 1 lsl (31 - 27)
+
+(* Record calls to the GC -- we've moved them out of the way *)
+
+type gc_call =
+  { gc_lbl: label;                      (* Entry label *)
+    gc_return_lbl: label;               (* Where to branch after GC *)
+    gc_desired_size: int;               (* Required block size *)
+    gc_instr: instruction }             (* Record live registers *)
+
+let call_gc_sites = ref ([] : gc_call list)
+
+let emit_call_gc gc =
+  `{emit_label gc.gc_lbl}:	ldiq	$25, {emit_int gc.gc_desired_size}\n`;
+  liveregs gc.gc_instr 0;
+  `	bsr	caml_call_gc\n`;
+  `	br	{emit_label gc.gc_return_lbl}\n`
+
+(* Record calls to caml_fast_modify -- we've moved then out of the way *)
+
+type modify_call =
+  { mod_lbl: label;                     (* Entry label *)
+    mod_return_lbl: label;              (* Where to branch after call *)
+    mod_instr: instruction }            (* Record live registers *)
+
+let modify_sites = ref ([] : modify_call list)
+
+let emit_modify mc =
+  let i = mc.mod_instr in
+  `{emit_label mc.mod_lbl}:	mov	{emit_reg i.arg.(0)}, $25\n`;
+  liveregs i (live_24 + live_25);
+  `	jsr	caml_fast_modify\n`; (* Pointer to block in $25, header in $24 *)
+  `	ldgp	$gp, 0($26)\n`;
+  `	br	{emit_label mc.mod_return_lbl}\n`
+
+(* Return the label occurring most frequently in an array of labels *)
+
+let most_frequent_element v =
+  let freq = Array.new (Array.length v) 0 in
+  for i = 0 to Array.length v - 1 do
+    try
+      for j = 0 to i - 1 do
+        if v.(i) = v.(j) then (freq.(j) <- freq.(j) + 1; raise Exit)
+      done;
+      freq.(i) <- 1
+    with Exit ->
+      ()
+  done;
+  let max_freq = ref 1 and max_freq_pos = ref 0 in
+  for i = 1 to Array.length v - 1 do
+    if freq.(i) > !max_freq then (max_freq := freq.(i); max_freq_pos := i)
+  done;
+  v.(!max_freq_pos)
+    
+
+(* Names of various instructions *)
+
+let name_for_int_operation = function
+    Iadd -> "addq"
+  | Isub -> "subq"
+  | Imul -> "mulq"
+  | Idiv -> "divq"
+  | Imod -> "remq"
+  | Iand -> "and"
+  | Ior -> "or"
+  | Ixor -> "xor"
+  | Ilsl -> "sll"
+  | Ilsr -> "srl"
+  | Iasr -> "sra"
+  | Icomp _ -> Misc.fatal_error "Emit.name_for_int_operation"
+
+let name_for_specific_operation = function
+    Iadd4 -> "s4addq"
+  | Iadd8 -> "s8addq"
+  | Isub4 -> "s4subq"
+  | Isub8 -> "s8subq"
+
+let name_for_int_comparison = function
+    Isigned Ceq -> "cmpeq", true     | Isigned Cne -> "cmpeq", false
+  | Isigned Cle -> "cmple", true     | Isigned Cgt -> "cmple", false
+  | Isigned Clt -> "cmplt", true     | Isigned Cge -> "cmplt", false
+  | Iunsigned Ceq -> "cmpeq", true   | Iunsigned Cne -> "cmpeq", false
+  | Iunsigned Cle -> "cmpule", true  | Iunsigned Cgt -> "cmpule", false
+  | Iunsigned Clt -> "cmpult", true  | Iunsigned Cge -> "cmpult", false
+
+(* Used for comparisons against 0 *)
+let name_for_int_cond_branch = function
+    Isigned Ceq -> "beq"     | Isigned Cne -> "bne"
+  | Isigned Cle -> "ble"     | Isigned Cgt -> "bgt"
+  | Isigned Clt -> "blt"     | Isigned Cge -> "bge"
+  | Iunsigned Ceq -> "beq"   | Iunsigned Cne -> "bne"
+  | Iunsigned Cle -> "beq"   | Iunsigned Cgt -> "bne"
+  | Iunsigned Clt -> "#"     | Iunsigned Cge -> "br"
+    (* Always false *)         (* Always true *)
+
+let name_for_float_comparison = function
+    Ceq -> "cmpteq", true   | Cne -> "cmpteq", false
+  | Cle -> "cmptle", true   | Cgt -> "cmptle", false
+  | Clt -> "cmptlt", true   | Cge -> "cmptlt", false
+
+(* Output the assembly code for an instruction *)
+
+(* Table of direct entry points (without setting GP) *)
+let nogp_entry_points = (Hashtbl.new 17 : (string, int) Hashtbl.t)
+(* Name of current function *)
+let function_name = ref ""
+(* Entry point for tail recursive calls *)
+let tailrec_entry_point = ref 0
+
+let emit_instr i =
+    match i.desc with
+      Lend -> ()
+    | Lop(Imove | Ispill | Ireload) ->
+        begin match (i.arg.(0).loc, i.res.(0).loc) with
+          (Reg rs, Reg rd) ->
+            if rs <> rd then
+            if i.arg.(0).typ = Float then
+              `	fmov	{emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
+            else
+              `	mov	{emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
+        | (Reg rs, Stack sd) ->
+            if i.arg.(0).typ = Float then
+              `	stt	{emit_reg i.arg.(0)}, {emit_stack i.res.(0)}\n`
+            else
+              `	stq	{emit_reg i.arg.(0)}, {emit_stack i.res.(0)}\n`
+        | (Stack ss, Reg rd) ->
+            if i.arg.(0).typ = Float then
+              `	ldt	{emit_reg i.res.(0)}, {emit_stack i.arg.(0)}\n`
+            else
+              `	ldq	{emit_reg i.res.(0)}, {emit_stack i.arg.(0)}\n`
+        | (_, _) ->
+            fatal_error "Emit_alpha: Imove"
+        end
+    | Lop(Iconstant cst) ->
+        begin match cst with
+          Const_int 0 | Const_pointer 0 ->
+            `	clr	{emit_reg i.res.(0)}\n`
+        | Const_int n ->
+            `	ldiq	{emit_reg i.res.(0)}, {emit_int n}\n`
+        | Const_float s ->
+            `	ldit	{emit_reg i.res.(0)}, {emit_string s}\n`
+        | Const_symbol s ->
+            `	lda	{emit_reg i.res.(0)}, {emit_symbol s}\n`
+        | Const_pointer n ->
+            `	ldiq	{emit_reg i.res.(0)}, {emit_int n}\n`
+        end
+    | Lop(Icall_ind) ->
+        `	mov	{emit_reg i.arg.(0)}, $27\n`;
+        liveregs i live_27;
+        `{record_frame i.live}	jsr	({emit_reg i.arg.(0)})\n`;
+        `	ldgp	$gp, 0($26)\n`
+    | Lop(Icall_imm s) ->
+        begin try
+          let entry_point = Hashtbl.find nogp_entry_points s in
+          liveregs i 0;
+          `{record_frame i.live}	bsr	{emit_label entry_point}\n`
+        with Not_found ->
+          `	lda	$27, {emit_symbol s}\n`;
+          liveregs i live_27;
+          `{record_frame i.live}	bsr	{emit_symbol s}\n`;
+          `	ldgp	$gp, 0($26)\n`
+        end
+    | Lop(Itailcall_ind) ->
+        let n = frame_size() in
+        if !contains_calls then
+          `	ldq	$26, {emit_int(n - 8)}($sp)\n`;
+        if n > 0 then
+          `	lda	$sp, {emit_int n}($sp)\n`;
+        `	mov	{emit_reg i.arg.(0)}, $27\n`;
+        liveregs i live_27;
+        `	jmp	({emit_reg i.arg.(0)})\n`
+    | Lop(Itailcall_imm s) ->
+        if s = !function_name then begin
+          `	br	{emit_label !tailrec_entry_point}\n`
+        end else begin
+          let n = frame_size() in
+          if !contains_calls then
+            `	ldq	$26, {emit_int(n - 8)}($sp)\n`;
+          if n > 0 then
+            `	lda	$sp, {emit_int n}($sp)\n`;
+          try
+            let entry_point = Hashtbl.find nogp_entry_points s in
+            liveregs i 0;
+            `	br	{emit_label entry_point}\n`
+          with Not_found ->
+            `	lda	$27, {emit_symbol s}\n`;
+            liveregs i live_27;
+            `	jmp	{emit_symbol s}\n`
+        end
+    | Lop(Iextcall s) ->
+        `	lda	$25, {emit_symbol s}\n`;
+        `	lda	$27, caml_c_call\n`;
+        liveregs i (live_25 + live_27);
+        `{record_frame i.live}	bsr	caml_c_call\n`;
+        `	ldgp	$gp, 0($26)\n`
+    | Lop(Istackoffset n) ->
+        `	lda	$sp, {emit_int (-n)}($sp)\n`;
+        stack_offset := !stack_offset + n
+    | Lop(Iload(chunk, addr)) ->
+        let load_instr =
+          match chunk with
+            Word -> if i.res.(0).typ = Float then "ldt" else "ldq"
+          | Byte_unsigned -> "ldbu"
+          | Byte_signed -> "ldb"
+          | Sixteen_unsigned -> "ldwu"
+          | Sixteen_signed -> "ldw" in
+        `	{emit_string load_instr}	{emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`
+    | Lop(Istore(chunk, addr)) ->
+        let store_instr =
+          match chunk with
+            Word -> if i.arg.(0).typ = Float then "stt" else "stq"
+          | Byte_unsigned | Byte_signed -> "stb"
+          | Sixteen_unsigned | Sixteen_signed -> "stw" in
+        `	{emit_string store_instr}	{emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
+    | Lop(Ialloc n) ->
+        if !fastcode_flag then begin
+          let lbl_cont = new_label() in
+          `	subq	$13, {emit_int n}, $13\n`;
+          `	cmpult	$13, $14, $25\n`;
+          let lbl_call_gc = record_frame_label i.live in
+          `	bne	$25, {emit_label lbl_call_gc}\n`;
+          call_gc_sites :=
+            { gc_lbl = lbl_call_gc;
+              gc_return_lbl = lbl_cont;
+              gc_desired_size = n;
+              gc_instr = i } :: !call_gc_sites;
+          `{emit_label lbl_cont}:	addq	$13, 8, {emit_reg i.res.(0)}\n`
+        end else begin
+          begin match n with
+            16 -> liveregs i 0;
+                  `{record_frame i.live}	bsr	caml_alloc1\n`
+          | 24 -> liveregs i 0;
+                  `{record_frame i.live}	bsr	caml_alloc2\n`
+          | 32 -> liveregs i 0;
+                  `{record_frame i.live}	bsr	caml_alloc3\n`
+          | _  -> `	ldiq	$25, {emit_int n}\n`;
+                  liveregs i live_25;
+                  `{record_frame i.live}	bsr	caml_alloc\n`
+          end;
+          `	addq	$13, 8, {emit_reg i.res.(0)}\n`
+        end
+    | Lop(Imodify) ->
+        if !fastcode_flag then begin
+          `	ldq	$24, -8({emit_reg i.arg.(0)})\n`;
+          `	and	$24, 1024, $25\n`;
+          let lbl_call_modify = new_label() in
+          let lbl_continue = new_label() in
+          `	beq	$25, {emit_label lbl_call_modify}\n`;
+          modify_sites :=
+            { mod_lbl = lbl_call_modify;
+              mod_return_lbl = lbl_continue;
+              mod_instr = i } :: !modify_sites;
+          `{emit_label lbl_continue}:`
+        end else begin
+          `	mov	{emit_reg i.arg.(0)}, $25\n`;
+          liveregs i live_25;
+          `	jsr	caml_modify\n`;  (* Pointer in $25 *)
+          `	ldgp	$gp, 0($26)\n`
+        end
+    | Lop(Iintop(Icomp cmp)) ->
+        let (comp, test) = name_for_int_comparison cmp in
+        `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`;
+        if not test then
+          `	xor	{emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop op) ->
+        let instr = name_for_int_operation op in
+        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop_imm(Icomp cmp, n)) ->
+        let (comp, test) = name_for_int_comparison cmp in
+        `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`;
+        if not test then
+          `	xor	{emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop_imm(op, n)) ->
+        let instr = name_for_int_operation op in
+        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`
+    | Lop(Iaddf) ->
+        `	addt	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
+    | Lop(Isubf) ->
+        `	subt	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
+    | Lop(Imulf) ->
+        `	mult	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
+    | Lop(Idivf) ->
+        `	divt	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
+    | Lop(Ifloatofint) ->
+        `	lda	$sp, -8($sp)\n`;
+        `	stq	{emit_reg i.arg.(0)}, 0($sp)\n`;
+        `	ldt	$f30, 0($sp)\n`;
+        `	cvtqt	$f30, {emit_reg i.res.(0)}\n`;
+        `	lda	$sp, 8($sp)\n`
+    | Lop(Iintoffloat) ->
+        `	lda	$sp, -8($sp)\n`;
+        `	cvttqc	{emit_reg i.arg.(0)}, $f30\n`;
+        `	stt	$f30, 0($sp)\n`;
+        `	ldq	{emit_reg i.res.(0)}, 0($sp)\n`;
+        `	lda	$sp, 8($sp)\n`
+    | Lop(Ilooptest tst) ->
+        fatal_error "Emit_alpha: looptest"
+    | Lop(Ispecific sop) ->
+        let instr = name_for_specific_operation sop in
+        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
+    | Lreturn ->
+        let n = frame_size() in
+        if !contains_calls then
+          `	ldq	$26, {emit_int(n - 8)}($sp)\n`;
+        if n > 0 then
+          `	lda	$sp, {emit_int n}($sp)\n`;
+        liveregs i 0;
+        `	ret	($26)\n`
+    | Llabel lbl ->
+        `{emit_label lbl}:\n`
+    | Lbranch lbl ->
+        `	br	{emit_label lbl}\n`
+    | Lcondbranch(tst, lbl) ->
+        begin match tst with
+          Ialwaystrue ->
+            `	br	{emit_label lbl}\n`
+        | Ialwaysfalse -> ()
+        | Itruetest ->
+            `	bne	{emit_reg i.arg.(0)}, {emit_label lbl}\n`
+        | Ifalsetest ->
+            `	beq	{emit_reg i.arg.(0)}, {emit_label lbl}\n`
+        | Iinttest cmp ->
+            let (comp, test) = name_for_int_comparison cmp in
+            `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`;
+            if test then
+              `	bne	$25, {emit_label lbl}\n`
+            else
+              `	beq	$25, {emit_label lbl}\n`
+        | Iinttest_imm(cmp, 0) ->
+            let branch = name_for_int_cond_branch cmp in
+            `	{emit_string branch}	{emit_reg i.arg.(0)}, {emit_label lbl}\n`
+        | Iinttest_imm(cmp, n) ->
+            let (comp, test) = name_for_int_comparison cmp in
+            `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_int n}, $25\n`;
+            if test then
+              `	bne	$25, {emit_label lbl}\n`
+            else
+              `	beq	$25, {emit_label lbl}\n`
+        | Ifloattest cmp ->
+            let (comp, test) = name_for_float_comparison cmp in
+            `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $f30\n`;
+            if test then
+              `	fbne	$f30, {emit_label lbl}\n`
+            else
+              `	fbeq	$f30, {emit_label lbl}\n`
+        end
+    | Lswitch jumptbl ->
+        (* We're assuming that the first case follows directly the switch
+           instruction, as linearize does. *)
+        begin match Array.length jumptbl with
+          0 -> ()       (* Should not happen... *)
+        | 1 -> ()       (* Should not happen... *)
+        | 2 ->
+            `	bne	{emit_reg i.arg.(0)}, {emit_label jumptbl.(1)}\n`
+        | 3 ->
+            `	subq	{emit_reg i.arg.(0)}, 1, $25\n`;
+            `	beq	$25, {emit_label jumptbl.(1)}\n`;
+            `	bgt	$25, {emit_label jumptbl.(2)}\n`
+        | 4 ->
+            `	subq	{emit_reg i.arg.(0)}, 2, $25\n`;
+            `	beq	$25, {emit_label jumptbl.(2)}\n`;
+            `	bgt	$25, {emit_label jumptbl.(3)}\n`;
+            `	bne	{emit_reg i.arg.(0)}, {emit_label jumptbl.(1)}\n`
+        | _ ->
+            let lbl_jumptbl = new_label() in
+            `	lda     $25, {emit_label lbl_jumptbl}\n`;
+            `	s4addq	{emit_reg i.arg.(0)}, $25, $25\n`;
+            `	ldl	$25, 0($25)\n`;
+            `	addq	$25, $gp, $25\n`;
+            let likely_target = most_frequent_element jumptbl in
+            liveregs i live_25;
+            `	jmp	($25), {emit_label likely_target}\n`;
+            `	.rdata\n`;
+            `{emit_label lbl_jumptbl}:\n`;
+            for i = 0 to Array.length jumptbl - 1 do
+              `	.gprel32	{emit_label jumptbl.(i)}\n`
+            done;
+            `	.text\n`
+        end
+    | Lpushtrap lbl ->
+        stack_offset := !stack_offset + 16;
+        `	lda	$sp, -16($sp)\n`;
+        `	lda	$25, {emit_label lbl}\n`;
+        `	stq	$15, 0($sp)\n`;
+        `	stq	$25, 8($sp)\n`;
+        `	mov	$sp, $15\n`
+    | Lpoptrap ->
+        `	ldq	$15, 0($sp)\n`;
+        `	lda	$sp, 16($sp)\n`;
+        stack_offset := !stack_offset - 16
+    | Lentertrap ->
+        `	ldgp	$gp, 0($27)\n`
+    | Lraise ->
+        `	mov	$15, $sp\n`;
+        `	ldq	$15, 0($sp)\n`;
+        `	ldq	$27, 8($sp)\n`;
+        `	lda	$sp, 16($sp)\n`;
+        liveregs i 0;
+        `	jmp	($27)\n`
+
+let rec emit_all i =
+  match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next
+
+(* Emission of a function declaration *)
+
+let fundecl fundecl =
+  function_name := fundecl.fun_name;
+  let noldgp_entry_point = new_label() in
+  tailrec_entry_point := new_label();
+  stack_offset := 0;
+  call_gc_sites := [];
+  modify_sites := [];
+  Hashtbl.add nogp_entry_points fundecl.fun_name noldgp_entry_point;
+  `	.text\n`;
+  `	.align	4\n`;
+  `	.globl	{emit_symbol fundecl.fun_name}\n`;
+  `	.ent	{emit_symbol fundecl.fun_name}\n`;
+  `{emit_symbol fundecl.fun_name}:\n`;
+  `	ldgp	$gp, 0($27)\n`;
+  `{emit_label noldgp_entry_point}:`;
+  let n = frame_size() in
+  if n > 0 then
+    `	lda	$sp, -{emit_int n}($sp)\n`
+  else
+    `\n`;
+  if !contains_calls then
+    `	stq	$26, {emit_int(n - 8)}($sp)\n`;
+  `	.prologue 1\n`;
+  `{emit_label !tailrec_entry_point}:`;
+  emit_all fundecl.fun_body;
+  List.iter emit_call_gc !call_gc_sites;
+  List.iter emit_modify !modify_sites;
+  `	.end	{emit_symbol fundecl.fun_name}\n`
+
+(* Emission of data *)
+
+let emit_item = function
+    Clabel lbl ->
+      `	.globl	{emit_symbol lbl}\n`;
+      `{emit_symbol lbl}:\n`
+  | Cint8 n ->
+      `	.byte	{emit_int n}\n`
+  | Cint16 n ->
+      `	.word	{emit_int n}\n`
+  | Cint n ->
+      `	.quad	{emit_int n}\n`
+  | Cfloat f ->
+      `	.double	{emit_string f}\n`
+  | Caddress lbl ->
+      `	.quad	{emit_symbol lbl}\n`
+  | Cstring s ->
+      let l = String.length s in
+      if l = 0 then ()
+      else if l < 80 then
+        `	.ascii	{emit_string_literal s}\n`
+      else begin
+        let i = ref 0 in
+        while !i < l do
+          let n = min (l - !i) 80 in
+          `	.ascii	{emit_string_literal(String.sub s !i n)}\n`;
+          i := !i + n
+        done
+      end
+  | Cskip n ->
+      if n > 0 then `	.space	{emit_int n}\n`
+  | Calign n ->
+      `	.align	{emit_int(Misc.log2 n)}\n`
+
+let data l =
+  `	.data\n`;
+  List.iter emit_item l
+
+(* Beginning / end of an assembly file *)
+
+let begin_assembly() = ()
+
+let end_assembly() =
+  `	.rdata\n`;
+  `	.globl	Frametable\n`;
+  `Frametable:\n`;
+  List.iter emit_frame !frame_descriptors;
+  frame_descriptors := [];
+  `	.quad	0\n`

asmcomp/emit_i386.mlp

+(* Emission of Intel 386 assembly code *)
+
+open Misc
+open Cmm
+open Arch
+open Proc
+open Reg
+open Mach
+open Linearize
+open Emitaux
+
+(* Tradeoff between code size and code speed *)
+
+let fastcode_flag = ref true
+
+(* Output a label *)
+
+let emit_label lbl =
+  emit_string "L"; emit_int lbl
+
+(* Output a pseudo-register *)
+
+let emit_reg r =
+  match r.loc with
+    Reg r ->
+      emit_string (register_name r)
+  | Stack s ->
+      let ofs = slot_offset s (register_class r) in
+      `{emit_int ofs}(%esp)`
+  | Unknown ->
+      fatal_error "Emit_i386.emit_reg"
+
+(* Same, but after one push in the floating-point register set *)
+
+let emit_shift r =
+  match r.loc with
+    Reg r ->
+      emit_string (register_name(r + 1))
+  | Stack s ->
+      let ofs = slot_offset s (register_class r) in
+      `{emit_int ofs}(%esp)`
+  | Unknown ->
+      fatal_error "Emit_i386.emit_shift"
+
+(* Output an addressing mode *)
+
+let emit_addressing addr r n =
+  match addr with
+    Ibased(s, d) ->
+      `_{emit_symbol s}`;
+      if d <> 0 then ` + {emit_int d}`
+  | Iindexed d ->
+      if d <> 0 then emit_int d;
+      `({emit_reg r.(n)})`
+  | Iindexed2 d ->
+      if d <> 0 then emit_int d;
+      `({emit_reg r.(n)}, {emit_reg r.(n+1)})`
+  | Iindexed2scaled(scale, d) ->
+      if d <> 0 then emit_int d;
+      `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})`
+
+(* Record live pointers at call points *)
+
+type frame_descr =
+  { fd_lbl: int;                        (* Return address *)
+    fd_frame_size: int;                 (* Size of stack frame *)
+    fd_live_offset: int list }          (* Offsets/regs of live addresses *)
+
+let frame_descriptors = ref([] : frame_descr list)
+
+let record_frame live =
+  let lbl = new_label() in
+  let live_offset = ref [] in
+  Reg.Set.iter
+    (function
+        {typ = Addr; loc = Reg r} ->
+          live_offset := (-1 - r) :: !live_offset
+      | {typ = Addr; loc = Stack s} as reg ->
+          live_offset := slot_offset s (register_class reg) :: !live_offset
+      | _ -> ())
+    live;
+  frame_descriptors :=
+    { fd_lbl = lbl;
+      fd_frame_size = frame_size();
+      fd_live_offset = !live_offset } :: !frame_descriptors;
+  `{emit_label lbl}:`
+
+let emit_frame fd =
+  `	.long	{emit_label fd.fd_lbl} + 4\n`;
+  `	.half	{emit_int fd.fd_frame_size}\n`;
+  `	.half	{emit_int (List.length fd.fd_live_offset)}\n`;
+  List.iter
+    (fun n ->
+      `	.half	{emit_int n}\n`)
+    fd.fd_live_offset
+
+(* Names for instructions *)
+
+let instr_for_intop = function
+    Iadd -> "addl"
+  | Isub -> "subl"
+  | Imul -> "imull"
+  | Iand -> "andl"
+  | Ior -> "orl"
+  | Ixor -> "xorl"
+  | Ilsl -> "sal"
+  | Ilsr -> "shr"
+  | Iasr -> "sar"
+  | _ -> fatal_error "Emit_i386: instr_for_intop"
+
+let name_for_cond_branch = function
+    Isigned Ceq -> "e"     | Isigned Cne -> "ne"
+  | Isigned Cle -> "le"     | Isigned Cgt -> "g"
+  | Isigned Clt -> "l"     | Isigned Cge -> "ge"
+  | Iunsigned Ceq -> "e"   | Iunsigned Cne -> "ne"
+  | Iunsigned Cle -> "be"  | Iunsigned Cgt -> "a"
+  | Iunsigned Clt -> "b"  | Iunsigned Cge -> "ae"
+    
+(* Output the assembly code for an instruction *)
+
+let function_name = ref ""
+let tailrec_entry_point = ref 0
+
+let float_constants = ref ([] : (int * string) list)
+
+let emit_instr i =
+    match i.desc with
+      Lend -> ()
+    | Lop(Imove | Ispill | Ireload) ->
+        if i.arg.(0).loc <> i.res.(0).loc then begin
+          match i.arg.(0).typ with
+            Int | Addr ->
+              `	movl	{emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
+          | Float ->
+              if i.arg.(0).loc = Reg 100 then
+                `	fstl	{emit_reg i.res.(0)}\n`
+              else begin
+                `	fldl	{emit_reg i.arg.(0)}\n`;
+                `	fstpl	{emit_shift i.res.(0)}\n`
+              end
+        end
+    | Lop(Iconstant cst) ->
+        begin match cst with
+          Const_int 0 | Const_pointer 0 ->
+            begin match i.res.(0).loc with
+              Reg n -> `	xorl	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
+            | _     -> `	movl	$0, {emit_reg i.res.(0)}\n`
+            end
+        | Const_int n ->
+            `	movl	${emit_int n}, {emit_reg i.res.(0)}\n`
+        | Const_float f ->
+            if float_of_string f = 0.0 then
+              `	fldz\n`
+            else begin
+              let lbl = new_label() in
+              float_constants := (lbl, f) :: !float_constants;
+              `	fldl	{emit_label lbl}\n`
+            end;
+            `	fstpl	{emit_shift i.res.(0)}\n`
+        | Const_symbol s ->
+            `	movl	$_{emit_symbol s}, {emit_reg i.res.(0)}\n`
+        | Const_pointer n ->
+            `	movl	${emit_int n}, {emit_reg i.res.(0)}\n`
+        end
+    | Lop(Icall_ind) ->
+        `{record_frame i.live}	call	*{emit_reg i.arg.(0)}\n`
+    | Lop(Icall_imm s) ->
+        `{record_frame i.live}	call	_{emit_symbol s}\n`
+    | Lop(Itailcall_ind) ->
+        let n = frame_size() - 4 in
+        if n > 0 then
+          `	addl	{emit_int n}, %esp\n`;
+        `	jmp	*{emit_reg i.arg.(0)}\n`
+    | Lop(Itailcall_imm s) ->
+        if s = !function_name then
+          `	jmp	{emit_label !tailrec_entry_point}\n`
+        else begin
+          let n = frame_size() - 4 in
+          if n > 0 then
+            `	addl	{emit_int n}, %esp\n`;
+          `	jmp	_{emit_symbol s}\n`
+        end
+    | Lop(Iextcall s) ->
+        `	movl	$_{emit_symbol s}, %eax\n`;
+        `{record_frame i.live}	call	_caml_c_call\n`
+    | Lop(Istackoffset n) ->
+        if n >= 0
+        then `	subl	{emit_int n}, %esp\n`
+        else `	addl	{emit_int(-n)}, %esp\n`;
+        stack_offset := !stack_offset + n
+    | Lop(Iload(chunk, addr)) ->
+        begin match i.res.(0).typ with
+          Int | Addr ->
+            let loadop =
+              match chunk with
+                Word -> "movl"
+              | Byte_unsigned -> "movzbl"
+              | Byte_signed -> "movsbl"
+              | Sixteen_unsigned -> "movzwl"
+              | Sixteen_signed -> "movswl" in
+            `	{emit_string loadop}	{emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n`
+        | Float ->
+            `	fldl	{emit_addressing addr i.arg 0}\n`;
+            `	fstpl	{emit_shift i.res.(0)}\n`
+        end
+    | Lop(Istore(Word, addr)) ->
+        begin match i.arg.(0).typ with
+          Int | Addr ->
+            `	movl	{emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
+        | Float ->
+            `	fldl	{emit_reg i.arg.(0)}\n`;
+            `	fstpl	{emit_addressing addr i.arg 1}\n`
+        end
+    | Lop(Istore(chunk, addr)) ->
+        (* i.arg.(0) is guaranteed to be in %edx *)
+        begin match chunk with
+          Word -> fatal_error "Emit_i386: store word"
+        | Byte_unsigned | Byte_signed ->
+            `	movb	%dl, {emit_addressing addr i.arg 1}\n`
+        | Sixteen_unsigned | Sixteen_signed ->
+            `	movw	%dx, {emit_addressing addr i.arg 1}\n`
+        end
+    | Lop(Ialloc n) ->
+        if !fastcode_flag then begin
+          `	movl	_young_ptr, %eax\n`;
+          `	subl	${emit_int n}, $eax\n`;
+          `	movl	%eax, _young_ptr\n`;
+          `	cmpl	_young_start, %eax`;
+          let lbl_cont = new_label() in
+          `	jae	{emit_label lbl_cont}\n`;
+          `	movl	${emit_int n}, %eax\n`;
+          `{record_frame i.live}	call	_caml_call_gc\n`;
+          `{emit_label lbl_cont}:	leal	4(%eax), {emit_reg i.res.(0)}\n`
+        end else begin
+          begin match n with
+            8  -> `{record_frame i.live}	call	_caml_alloc1\n`
+          | 12 -> `{record_frame i.live}	call	_caml_alloc2\n`
+          | 16 -> `{record_frame i.live}	call	_caml_alloc3\n`
+          | _  -> `	movl	${emit_int n}, %eax\n`;
+                  `{record_frame i.live}	call	_caml_alloc\n`
+          end;
+          `	leal	4(%eax), {emit_reg i.res.(0)}\n`
+        end
+    | Lop(Imodify) ->
+        (* Argument is in eax *)
+        if !fastcode_flag then begin
+          `	btsl	10, -4(%eax)\n`;
+          let lbl_cont = new_label() in
+          `	jc	{emit_label lbl_cont}\n`;
+          `	call	_caml_fast_modify\n`;
+          `{emit_label lbl_cont}:\n`
+        end else
+          `	call	_caml_modify\n`
+    | Lop(Iintop(Icomp cmp)) ->
+        `	cmpl	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
+        let b = name_for_cond_branch cmp in
+        `	set{emit_string b}	%al\n`;
+        `	movzbl	%al, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop_imm(Icomp cmp, n)) ->
+        `	cmpl	${emit_int n}, {emit_reg i.arg.(0)}\n`;
+        let b = name_for_cond_branch cmp in
+        `	set{emit_string b}	%al\n`;
+        `	movzbl	%al, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop(Idiv | Imod)) ->
+        `	cltd\n`;
+        `	idivl	{emit_reg i.arg.(1)}\n`
+    | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) ->
+        (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *)
+        `	{emit_string(instr_for_intop op)}	%cl, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop op) ->
+        (* We have i.arg.(0) = i.res.(0) *)
+        `	{emit_string(instr_for_intop op)}	{emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) ->
+        `	incl	{emit_reg i.res.(0)}\n`
+    | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) ->
+        `	decl	{emit_reg i.res.(0)}\n`
+    | Lop(Iintop_imm(op, n)) ->
+        (* We have i.arg.(0) = i.res.(0) *)
+        `	{emit_string(instr_for_intop op)}	${emit_int n}, {emit_reg i.res.(0)}\n`
+    | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) ->
+        let instr =
+          match floatop with
+              Iaddf -> "fadd"
+            | Isubf -> "fsub"
+            | Imulf -> "fmul"
+            | Idivf -> "fdiv"
+            | _ -> fatal_error "Emit_i386.emit_instr: floatop" in
+        `	fldl	{emit_reg i.arg.(0)}\n`;
+        begin match i.arg.(1).loc with
+          Stack s ->
+            `	{emit_string instr}l	{emit_shift i.arg.(1)}\n`
+        | _ ->
+            `	{emit_string instr}	{emit_shift i.arg.(1)}\n`
+        end;
+        `	fstpl	{emit_shift i.res.(0)}\n`
+    | Lop(Ifloatofint) ->
+        begin match i.arg.(0).loc with
+          Stack s ->
+            `	fildl	{emit_reg i.arg.(0)}\n`;
+            `	fstpl	{emit_shift i.res.(0)}\n`
+        | _ ->
+            `	pushl	{emit_reg i.arg.(0)}\n`;
+            stack_offset := !stack_offset + 4;
+            `	fildl	(%esp)\n`;
+            `	fstpl	{emit_shift i.res.(0)}\n`;
+            `	addl	$4, %esp\n`;
+            stack_offset := !stack_offset - 4
+        end
+    | Lop(Iintoffloat) ->
+        stack_offset := !stack_offset - 8;
+        `	subl	$8, %esp\n`;
+        `	fnstcw	4(%esp)\n`;
+        `	movl	4(%esp), %eax\n`;
+        `	movb    $12, %ah\n`;
+        `	movl	%eax, (%esp)\n`;
+        `	fldcw	(%esp)\n`;
+        `	fldl	{emit_reg i.arg.(0)}\n`;
+        begin match i.res.(0).loc with
+          Stack s ->
+            `	fistpl	{emit_shift i.res.(0)}\n`
+        | _ ->
+            `	fistpl	(%esp)\n`;
+            `	movl	(%esp), {emit_reg i.res.(0)}\n`
+        end;
+        `	addl	$8, %esp\n`;
+        stack_offset := !stack_offset + 8
+    | Lop(Ispecific Ineg) ->
+        `	neg	{emit_reg i.res.(0)}\n`
+    | Lop(Ispecific(Ilea addr)) ->
+        `	lea	{emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n`
+    | Lop(Ilooptest tst) ->
+        fatal_error "Emit_i386: looptest"
+    | Lreturn ->
+        let n = frame_size() - 4 in
+        if n > 0 then
+          `	addl	${emit_int n}, %esp\n`;
+        `	ret\n`
+    | Llabel lbl ->
+        `{emit_label lbl}:\n`
+    | Lbranch lbl ->
+        `	jmp	{emit_label lbl}\n`
+    | Lcondbranch(tst, lbl) ->
+        begin match tst with
+          Ialwaystrue ->
+            `	jmp	{emit_label lbl}\n`
+        | Ialwaysfalse -> ()
+        | Itruetest ->
+            `	cmpl	$0, {emit_reg i.arg.(0)}\n`;
+            `	jne	{emit_label lbl}\n`
+        | Ifalsetest ->
+            `	cmpl	$0, {emit_reg i.arg.(0)}\n`;
+            `	je	{emit_label lbl}\n`
+        | Iinttest cmp ->
+            `	cmpl	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
+            let b = name_for_cond_branch cmp in
+            `	j{emit_string b}	{emit_label lbl}\n`
+        | Iinttest_imm(cmp, n) ->
+            `	cmpl	${emit_int n}, {emit_reg i.arg.(0)}\n`;
+            let b = name_for_cond_branch cmp in
+            `	j{emit_string b}	{emit_label lbl}\n`
+        | Ifloattest cmp ->
+            `	fnstsw	%ax\n`;
+            match cmp with
+              Ceq ->
+                `	andb	$69, %al\n`;
+                `	cmpb	$64, %al\n`;
+                `	je	{emit_label lbl}\n`
+            | Cne ->
+                `	andb	$68, %al\n`;
+                `	xorb	$64, %al\n`;
+                `	jne	{emit_label lbl}\n`
+            | Cle ->
+                `	andb	$69, %al\n`;
+                `	decb	%al\n`;
+                `	cmpb	$64, %al\n`;
+                `	jb	{emit_label lbl}\n`
+            | Cge ->
+                `	andb	$5, %al\n`;
+                `	je	{emit_label lbl}\n`
+            | Clt ->
+                `	andb	$69, %al\n`;
+                `	cmpb	$1, %al\n`;
+                `	je	{emit_label lbl}\n`
+            | Cgt ->
+                `	andb	$69, %al\n`;
+                `	je	{emit_label lbl}\n`
+        end
+    | Lswitch jumptbl ->
+        begin match Array.length jumptbl with
+          0 -> ()
+        | 1 -> ()
+        | 2 ->
+            `	cmpl	$0, {emit_reg i.arg.(0)}\n`;
+            `	jne	{emit_label jumptbl.(1)}\n`
+        | 3 ->
+            `	cmpl	$1, {emit_reg i.arg.(0)}\n`;
+            `	jg	{emit_label jumptbl.(2)}\n`;
+            `	je	{emit_label jumptbl.(1)}\n`
+        | n ->
+          let lbl = new_label() in
+          `	jmp	*{emit_label lbl}(, {emit_reg i.arg.(0)}, 4)\n`;
+          `	.align	2\n`;
+          `{emit_label lbl}:`;
+          for i = 0 to n - 1 do
+            `	.long	{emit_label jumptbl.(i)}\n`
+          done
+        end
+    | Lpushtrap lbl ->
+        `	pushl	_caml_exception_pointer\n`;
+        `	pushl	${emit_label lbl}\n`;
+        `	movl	%esp, _caml_exception_pointer\n`;
+        stack_offset := !stack_offset + 8
+    | Lpoptrap ->
+        `	addl	$4, %esp\n`;
+        `	popl	_caml_exception_pointer\n`;
+        stack_offset := !stack_offset - 8
+    | Lentertrap ->
+        ()
+    | Lraise ->
+        `	movl	_caml_exception_pointer, %esp\n`;
+        `	popl	%edx\n`;
+        `	popl    _caml_exception_pointer\n`;
+        `	jmp	*%edx\n`
+
+let rec emit_all i =
+  match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next
+
+(* Emission of the floating-point constants *)
+
+let emit_float_constant (lbl, cst) =
+  `	.data\n`;
+  `{emit_label lbl}:	.double	{emit_string cst}\n`
+
+(* Emission of a function declaration *)
+
+let fundecl fundecl =
+  function_name := fundecl.fun_name;
+  tailrec_entry_point := new_label();
+  stack_offset := 0;
+  float_constants := [];
+  `	.text\n`;
+  `	.align	4\n`;
+  `	.globl	_{emit_symbol fundecl.fun_name}\n`;
+  `_{emit_symbol fundecl.fun_name}:\n`;
+  let n = frame_size() - 4 in
+  if n > 0 then
+    `	subl	${emit_int n}, %esp\n`;
+  `{emit_label !tailrec_entry_point}:`;
+  emit_all fundecl.fun_body;
+  List.iter emit_float_constant !float_constants
+
+(* Emission of data *)
+
+let emit_item = function
+    Clabel lbl ->
+      `	.globl	_{emit_symbol lbl}\n`;
+      `_{emit_symbol lbl}:\n`
+  | Cint8 n ->
+      `	.byte	{emit_int n}\n`
+  | Cint16 n ->
+      `	.word	{emit_int n}\n`
+  | Cint n ->
+      `	.long	{emit_int n}\n`
+  | Cfloat f ->
+      `	.double	{emit_string f}\n`
+  | Caddress lbl ->
+      `	.long	_{emit_symbol lbl}\n`
+  | Cstring s ->
+      let l = String.length s in
+      if l = 0 then ()
+      else if l < 80 then
+        `	.ascii	{emit_string_literal s}\n`
+      else begin
+        let i = ref 0 in
+        while !i < l do
+          let n = min (l - !i) 80 in
+          `	.ascii	{emit_string_literal(String.sub s !i n)}\n`;
+          i := !i + n
+        done
+      end
+  | Cskip n ->
+      if n > 0 then `	.space	{emit_int n}\n`
+  | Calign n ->
+      `	.align	{emit_int(Misc.log2 n)}\n`
+
+let data l =
+  `	.data\n`;
+  List.iter emit_item l
+
+(* Beginning / end of an assembly file *)
+
+let begin_assembly() = ()
+
+let end_assembly() =
+  `	.data\n`;
+  `	.globl	_Frametable\n`;
+  `_Frametable:\n`;
+  List.iter emit_frame !frame_descriptors;
+  frame_descriptors := [];
+  `	.long	0\n`

asmcomp/emit_sparc.mlp

+(* Emission of Sparc assembly code *)
+
+open Misc
+open Cmm
+open Arch
+open Proc
+open Reg
+open Mach
+open Linearize
+open Emitaux
+
+(* Tradeoff between code size and code speed *)
+
+let fastcode_flag = ref true
+
+(* Return the other register in a register pair *)
+
+let next_in_pair = function
+    {loc = Reg r; typ = (Int | Addr)} -> phys_reg (r + 1)
+  | {loc = Reg r; typ = Float} -> phys_reg (r + 15)
+  | _ -> fatal_error "Emit.next_in_pair"
+
+(* Output a label *)
+
+let emit_label lbl =
+  emit_string "L"; emit_int lbl
+
+(* Output a pseudo-register *)
+
+let emit_reg r =
+  match r.loc with
+    Reg r -> emit_string (register_name r)
+  | _ -> fatal_error "Emit.emit_reg"
+
+(* Output a stack reference *)
+
+let emit_stack r =
+  match r.loc with
+    Stack s ->
+      let ofs = slot_offset s (register_class r) in `[%sp + {emit_int ofs}]`
+  | _ -> fatal_error "Emit.emit_stack"
+
+(* Output a load *)
+
+let emit_load instr addr arg dst =
+  match addr with
+    Ibased(s, 0) ->
+        `	sethi	%hi(_{emit_symbol s}), %g1\n`;
+        `	{emit_string instr}	[%g1 + %lo(_{emit_symbol s})], {emit_reg dst}\n`
+  | Ibased(s, ofs) ->
+        `	sethi	%hi(_{emit_symbol s} + {emit_int ofs}), %g1\n`;
+        `	{emit_string instr}	[%g1 + %lo(_{emit_symbol s} + {emit_int ofs})], {emit_reg dst}\n`
+  | Iindexed ofs ->
+      if is_immediate ofs then
+        `	{emit_string instr}	[{emit_reg arg.(0)} + {emit_int ofs}], {emit_reg dst}\n`
+      else begin
+        `	sethi	%hi({emit_int ofs}), %g1\n`;
+        `	or	%g1, %lo({emit_int ofs}), %g1\n`;
+        `	{emit_string instr}	[{emit_reg arg.(0)} + %g1], {emit_reg dst}\n`
+      end
+  | Iindexed2 ofs ->
+      if ofs = 0 then
+        `	{emit_string instr}	[{emit_reg arg.(0)} + {emit_reg arg.(1)}], {emit_reg dst}\n`
+      else if is_immediate ofs then begin
+        `	add	{emit_reg arg.(1)}, {emit_int ofs}, %g1\n`;
+        `	{emit_string instr}	[{emit_reg arg.(0)} + %g1], {emit_reg dst}\n`
+      end else begin
+        `	sethi	%hi({emit_int ofs}), %g1\n`;
+        `	or	%g1, %lo({emit_int ofs}), %g1\n`;
+        `	add	{emit_reg arg.(1)}, %g1, %g1\n`;
+        `	{emit_string instr}	[{emit_reg arg.(0)} + %g1], {emit_reg dst}\n`
+      end
+
+(* Output a store *)
+
+let emit_store instr addr arg src =
+  match addr with
+    Ibased(s, 0) ->
+        `	sethi	%hi(_{emit_symbol s}), %g1\n`;
+        `	{emit_string instr}	{emit_reg src}, [%g1 + %lo(_{emit_symbol s})]\n`
+  | Ibased(s, ofs) ->
+        `	sethi	%hi(_{emit_symbol s} + {emit_int ofs}), %g1\n`;
+        `	{emit_string instr}	{emit_reg src}, [%g1 + %lo(_{emit_symbol s} + {emit_int ofs})]\n`
+  | Iindexed ofs ->
+      if is_immediate ofs then
+        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + {emit_int ofs}]\n`
+      else begin
+        `	sethi	%hi({emit_int ofs}), %g1\n`;
+        `	or	%g1, %lo({emit_int ofs}), %g1\n`;
+        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + %g1]\n`
+      end
+  | Iindexed2 ofs ->
+      if ofs = 0 then
+        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + {emit_reg arg.(2)}]\n`
+      else if is_immediate ofs then begin
+        `	add	{emit_reg arg.(2)}, {emit_int ofs}, %g1\n`;
+        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + %g1]\n`
+      end else begin
+        `	sethi	%hi({emit_int ofs}), %g1\n`;
+        `	or	%g1, %lo({emit_int ofs}), %g1\n`;
+        `	add	{emit_reg arg.(2)}, %g1, %g1\n`;
+        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + %g1]\n`
+      end
+
+(* Record live pointers at call points *)
+
+type frame_descr =
+  { fd_lbl: int;                        (* Return address *)
+    fd_frame_size: int;                 (* Size of stack frame *)
+    fd_live_offset: int list }          (* Offsets/regs of live addresses *)
+
+let frame_descriptors = ref([] : frame_descr list)
+
+let record_frame live =
+  let lbl = new_label() in
+  let live_offset = ref [] in
+  Reg.Set.iter
+    (function
+        {typ = Addr; loc = Reg r} ->
+          live_offset := (-1 - r) :: !live_offset