Nouvelle architecture pour les fichiers dependant du processeur
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@1655 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
Xavier Leroy
parent
4029d102d8
commit
119c8eeb67
87
.depend
87
.depend
|
|
@ -350,20 +350,17 @@ asmcomp/mach.cmi: asmcomp/arch.cmo asmcomp/cmm.cmi utils/nativeint.cmi \
|
|||
asmcomp/printcmm.cmi: asmcomp/cmm.cmi
|
||||
asmcomp/printlinear.cmi: asmcomp/linearize.cmi
|
||||
asmcomp/printmach.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
|
||||
asmcomp/proc.cmi: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \
|
||||
asmcomp/reg.cmi
|
||||
asmcomp/proc.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
|
||||
asmcomp/reg.cmi: asmcomp/cmm.cmi
|
||||
asmcomp/reload.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
|
||||
asmcomp/reload.cmi: asmcomp/mach.cmi
|
||||
asmcomp/reloadgen.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
|
||||
asmcomp/schedgen.cmi: asmcomp/linearize.cmi asmcomp/mach.cmi
|
||||
asmcomp/scheduling.cmi: asmcomp/linearize.cmi
|
||||
asmcomp/selectgen.cmi: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \
|
||||
asmcomp/mach.cmi asmcomp/reg.cmi utils/tbl.cmi
|
||||
asmcomp/selection.cmi: asmcomp/cmm.cmi asmcomp/mach.cmi
|
||||
asmcomp/spill.cmi: asmcomp/mach.cmi
|
||||
asmcomp/split.cmi: asmcomp/mach.cmi
|
||||
asmcomp/arch_mips.cmo: utils/config.cmi utils/misc.cmi
|
||||
asmcomp/arch_mips.cmx: utils/config.cmx utils/misc.cmx
|
||||
asmcomp/arch_power.cmo: utils/misc.cmi
|
||||
asmcomp/arch_power.cmx: utils/misc.cmx
|
||||
asmcomp/arch_sparc.cmo: utils/misc.cmi
|
||||
asmcomp/arch_sparc.cmx: utils/misc.cmx
|
||||
asmcomp/asmgen.cmo: utils/clflags.cmo asmcomp/closure.cmi asmcomp/cmm.cmi \
|
||||
asmcomp/cmmgen.cmi asmcomp/coloring.cmi utils/config.cmi asmcomp/emit.cmi \
|
||||
asmcomp/emitaux.cmi asmcomp/interf.cmi asmcomp/linearize.cmi \
|
||||
|
|
@ -435,11 +432,11 @@ asmcomp/compilenv.cmo: asmcomp/clambda.cmi utils/config.cmi typing/env.cmi \
|
|||
asmcomp/compilenv.cmx: asmcomp/clambda.cmx utils/config.cmx typing/env.cmx \
|
||||
typing/ident.cmx utils/misc.cmx asmcomp/compilenv.cmi
|
||||
asmcomp/emit.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/compilenv.cmi \
|
||||
utils/config.cmi asmcomp/emitaux.cmi asmcomp/linearize.cmi \
|
||||
asmcomp/emitaux.cmi asmcomp/linearize.cmi parsing/location.cmi \
|
||||
asmcomp/mach.cmi utils/misc.cmi utils/nativeint.cmi asmcomp/proc.cmi \
|
||||
asmcomp/reg.cmi asmcomp/emit.cmi
|
||||
asmcomp/emit.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/compilenv.cmx \
|
||||
utils/config.cmx asmcomp/emitaux.cmx asmcomp/linearize.cmx \
|
||||
asmcomp/emitaux.cmx asmcomp/linearize.cmx parsing/location.cmx \
|
||||
asmcomp/mach.cmx utils/misc.cmx utils/nativeint.cmx asmcomp/proc.cmx \
|
||||
asmcomp/reg.cmx asmcomp/emit.cmi
|
||||
asmcomp/emitaux.cmo: utils/nativeint.cmi asmcomp/emitaux.cmi
|
||||
|
|
@ -478,56 +475,32 @@ asmcomp/proc.cmo: asmcomp/arch.cmo utils/ccomp.cmi asmcomp/cmm.cmi \
|
|||
asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi asmcomp/proc.cmi
|
||||
asmcomp/proc.cmx: asmcomp/arch.cmx utils/ccomp.cmx asmcomp/cmm.cmx \
|
||||
asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx asmcomp/proc.cmi
|
||||
asmcomp/proc_alpha.cmo: asmcomp/arch.cmo utils/ccomp.cmi asmcomp/cmm.cmi \
|
||||
asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi
|
||||
asmcomp/proc_alpha.cmx: asmcomp/arch.cmx utils/ccomp.cmx asmcomp/cmm.cmx \
|
||||
asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx
|
||||
asmcomp/proc_hppa.cmo: asmcomp/arch.cmo utils/ccomp.cmi asmcomp/cmm.cmi \
|
||||
utils/config.cmi asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi
|
||||
asmcomp/proc_hppa.cmx: asmcomp/arch.cmx utils/ccomp.cmx asmcomp/cmm.cmx \
|
||||
utils/config.cmx asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx
|
||||
asmcomp/proc_i386.cmo: asmcomp/arch.cmo utils/ccomp.cmi asmcomp/cmm.cmi \
|
||||
asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi
|
||||
asmcomp/proc_i386.cmx: asmcomp/arch.cmx utils/ccomp.cmx asmcomp/cmm.cmx \
|
||||
asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx
|
||||
asmcomp/proc_i386nt.cmo: asmcomp/arch.cmo utils/ccomp.cmi asmcomp/cmm.cmi \
|
||||
asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi
|
||||
asmcomp/proc_i386nt.cmx: asmcomp/arch.cmx utils/ccomp.cmx asmcomp/cmm.cmx \
|
||||
asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx
|
||||
asmcomp/proc_m68k.cmo: asmcomp/arch.cmo utils/ccomp.cmi asmcomp/cmm.cmi \
|
||||
asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi
|
||||
asmcomp/proc_m68k.cmx: asmcomp/arch.cmx utils/ccomp.cmx asmcomp/cmm.cmx \
|
||||
asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx
|
||||
asmcomp/proc_mips.cmo: asmcomp/arch.cmo utils/ccomp.cmi asmcomp/cmm.cmi \
|
||||
utils/config.cmi asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi
|
||||
asmcomp/proc_mips.cmx: asmcomp/arch.cmx utils/ccomp.cmx asmcomp/cmm.cmx \
|
||||
utils/config.cmx asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx
|
||||
asmcomp/proc_power.cmo: asmcomp/arch.cmo utils/ccomp.cmi asmcomp/cmm.cmi \
|
||||
utils/config.cmi asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi
|
||||
asmcomp/proc_power.cmx: asmcomp/arch.cmx utils/ccomp.cmx asmcomp/cmm.cmx \
|
||||
utils/config.cmx asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx
|
||||
asmcomp/proc_sparc.cmo: asmcomp/arch.cmo utils/ccomp.cmi asmcomp/cmm.cmi \
|
||||
asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi
|
||||
asmcomp/proc_sparc.cmx: asmcomp/arch.cmx utils/ccomp.cmx asmcomp/cmm.cmx \
|
||||
asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx
|
||||
asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi
|
||||
asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi
|
||||
asmcomp/reload.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \
|
||||
asmcomp/reg.cmi asmcomp/reload.cmi
|
||||
asmcomp/reload.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \
|
||||
asmcomp/reg.cmx asmcomp/reload.cmi
|
||||
asmcomp/scheduling.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi \
|
||||
asmcomp/linearize.cmi asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \
|
||||
asmcomp/reg.cmi asmcomp/scheduling.cmi
|
||||
asmcomp/scheduling.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx \
|
||||
asmcomp/linearize.cmx asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \
|
||||
asmcomp/reg.cmx asmcomp/scheduling.cmi
|
||||
asmcomp/selection.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \
|
||||
asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reload.cmi
|
||||
asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi
|
||||
asmcomp/reloadgen.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi \
|
||||
asmcomp/reloadgen.cmi
|
||||
asmcomp/reloadgen.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx \
|
||||
asmcomp/reloadgen.cmi
|
||||
asmcomp/schedgen.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/linearize.cmi \
|
||||
asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi asmcomp/schedgen.cmi
|
||||
asmcomp/schedgen.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/linearize.cmx \
|
||||
asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx asmcomp/schedgen.cmi
|
||||
asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi
|
||||
asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi
|
||||
asmcomp/selectgen.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \
|
||||
asmcomp/mach.cmi utils/misc.cmi utils/nativeint.cmi asmcomp/proc.cmi \
|
||||
asmcomp/reg.cmi utils/tbl.cmi asmcomp/selection.cmi
|
||||
asmcomp/selection.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx typing/ident.cmx \
|
||||
asmcomp/reg.cmi utils/tbl.cmi asmcomp/selectgen.cmi
|
||||
asmcomp/selectgen.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx typing/ident.cmx \
|
||||
asmcomp/mach.cmx utils/misc.cmx utils/nativeint.cmx asmcomp/proc.cmx \
|
||||
asmcomp/reg.cmx utils/tbl.cmx asmcomp/selection.cmi
|
||||
asmcomp/reg.cmx utils/tbl.cmx asmcomp/selectgen.cmi
|
||||
asmcomp/selection.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \
|
||||
utils/misc.cmi asmcomp/reg.cmi asmcomp/selectgen.cmi \
|
||||
asmcomp/selection.cmi
|
||||
asmcomp/selection.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \
|
||||
utils/misc.cmx asmcomp/reg.cmx asmcomp/selectgen.cmx \
|
||||
asmcomp/selection.cmi
|
||||
asmcomp/spill.cmo: asmcomp/mach.cmi asmcomp/proc.cmi asmcomp/reg.cmi \
|
||||
asmcomp/spill.cmi
|
||||
asmcomp/spill.cmx: asmcomp/mach.cmx asmcomp/proc.cmx asmcomp/reg.cmx \
|
||||
|
|
|
|||
50
Makefile
50
Makefile
|
|
@ -51,10 +51,12 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/cmm.cmo asmcomp/printcmm.cmo \
|
|||
asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
|
||||
asmcomp/clambda.cmo asmcomp/compilenv.cmo \
|
||||
asmcomp/closure.cmo asmcomp/cmmgen.cmo \
|
||||
asmcomp/printmach.cmo asmcomp/selection.cmo asmcomp/liveness.cmo \
|
||||
asmcomp/spill.cmo asmcomp/split.cmo \
|
||||
asmcomp/interf.cmo asmcomp/coloring.cmo asmcomp/reload.cmo \
|
||||
asmcomp/printlinear.cmo asmcomp/linearize.cmo asmcomp/scheduling.cmo \
|
||||
asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
|
||||
asmcomp/liveness.cmo asmcomp/spill.cmo asmcomp/split.cmo \
|
||||
asmcomp/interf.cmo asmcomp/coloring.cmo \
|
||||
asmcomp/reloadgen.cmo asmcomp/reload.cmo \
|
||||
asmcomp/printlinear.cmo asmcomp/linearize.cmo \
|
||||
asmcomp/schedgen.cmo asmcomp/scheduling.cmo \
|
||||
asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \
|
||||
asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo
|
||||
|
||||
|
|
@ -132,8 +134,10 @@ coldstart:
|
|||
ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi
|
||||
|
||||
# Save the current bootstrap compiler
|
||||
MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev
|
||||
backup:
|
||||
if test -d boot/Saved; then : ; else mkdir boot/Saved; fi
|
||||
if test -d $(MAXSAVED); then rm -r $(MAXSAVED); else : ; fi
|
||||
mv boot/Saved boot/Saved.prev
|
||||
mkdir boot/Saved
|
||||
mv boot/Saved.prev boot/Saved/Saved.prev
|
||||
|
|
@ -334,28 +338,52 @@ partialclean::
|
|||
|
||||
beforedepend:: bytecomp/runtimedef.ml
|
||||
|
||||
# Choose the right arch, emit and proc files
|
||||
# Choose the right machine-dependent files
|
||||
|
||||
asmcomp/arch.ml: asmcomp/arch_$(ARCH).ml
|
||||
ln -s arch_$(ARCH).ml asmcomp/arch.ml
|
||||
asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml
|
||||
ln -s $(ARCH)/arch.ml asmcomp/arch.ml
|
||||
|
||||
partialclean::
|
||||
rm -f asmcomp/arch.ml
|
||||
|
||||
beforedepend:: asmcomp/arch.ml
|
||||
|
||||
asmcomp/proc.ml: asmcomp/proc_$(ARCH).ml
|
||||
ln -s proc_$(ARCH).ml asmcomp/proc.ml
|
||||
asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml
|
||||
ln -s $(ARCH)/proc.ml asmcomp/proc.ml
|
||||
|
||||
partialclean::
|
||||
rm -f asmcomp/proc.ml
|
||||
|
||||
beforedepend:: asmcomp/proc.ml
|
||||
|
||||
asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml
|
||||
ln -s $(ARCH)/selection.ml asmcomp/selection.ml
|
||||
|
||||
partialclean::
|
||||
rm -f asmcomp/selection.ml
|
||||
|
||||
beforedepend:: asmcomp/selection.ml
|
||||
|
||||
asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml
|
||||
ln -s $(ARCH)/reload.ml asmcomp/reload.ml
|
||||
|
||||
partialclean::
|
||||
rm -f asmcomp/reload.ml
|
||||
|
||||
beforedepend:: asmcomp/reload.ml
|
||||
|
||||
asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml
|
||||
ln -s $(ARCH)/scheduling.ml asmcomp/scheduling.ml
|
||||
|
||||
partialclean::
|
||||
rm -f asmcomp/scheduling.ml
|
||||
|
||||
beforedepend:: asmcomp/scheduling.ml
|
||||
|
||||
# Preprocess the code emitters
|
||||
|
||||
asmcomp/emit.ml: asmcomp/emit_$(ARCH).mlp tools/cvt_emit
|
||||
boot/ocamlrun tools/cvt_emit < asmcomp/emit_$(ARCH).mlp > asmcomp/emit.ml \
|
||||
asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit
|
||||
boot/ocamlrun tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml \
|
||||
|| { rm -f asmcomp/emit.ml; exit 2; }
|
||||
|
||||
partialclean::
|
||||
|
|
|
|||
50
Makefile.nt
50
Makefile.nt
|
|
@ -48,10 +48,12 @@ ASMCOMP=asmcomp\arch.cmo asmcomp\cmm.cmo asmcomp\printcmm.cmo \
|
|||
asmcomp\reg.cmo asmcomp\mach.cmo asmcomp\proc.cmo \
|
||||
asmcomp\clambda.cmo asmcomp\compilenv.cmo \
|
||||
asmcomp\closure.cmo asmcomp\cmmgen.cmo \
|
||||
asmcomp\printmach.cmo asmcomp\selection.cmo asmcomp\liveness.cmo \
|
||||
asmcomp\spill.cmo asmcomp\split.cmo \
|
||||
asmcomp\interf.cmo asmcomp\coloring.cmo asmcomp\reload.cmo \
|
||||
asmcomp\printlinear.cmo asmcomp\linearize.cmo asmcomp\scheduling.cmo \
|
||||
asmcomp\printmach.cmo asmcomp\selectgen.cmo asmcomp\selection.cmo \
|
||||
asmcomp\liveness.cmo asmcomp\spill.cmo asmcomp\split.cmo \
|
||||
asmcomp\interf.cmo asmcomp\coloring.cmo \
|
||||
asmcomp\reloadgen.cmo asmcomp\reload.cmo \
|
||||
asmcomp\printlinear.cmo asmcomp\linearize.cmo \
|
||||
asmcomp\schedgen.cmo asmcomp\scheduling.cmo \
|
||||
asmcomp\emitaux.cmo asmcomp\emit.cmo asmcomp\asmgen.cmo \
|
||||
asmcomp\asmlink.cmo asmcomp\asmlibrarian.cmo
|
||||
|
||||
|
|
@ -130,8 +132,10 @@ coldstart:
|
|||
cd stdlib & cp $(LIBFILES) ..\boot
|
||||
|
||||
# Save the current bootstrap compiler
|
||||
MAXSAVED=boot\Saved\Saved.prev\Saved.prev\Saved.prev\Saved.prev\Saved.prev
|
||||
backup:
|
||||
if not exist boot\Saved mkdir boot\Saved
|
||||
if exist $(MAXSAVED) rm -r $(MAXSAVED)
|
||||
mv boot\Saved boot\Saved.prev
|
||||
mkdir boot\Saved
|
||||
mv boot\Saved.prev boot\Saved\Saved.prev
|
||||
|
|
@ -332,28 +336,52 @@ partialclean::
|
|||
|
||||
beforedepend:: bytecomp\runtimedef.ml
|
||||
|
||||
# Choose the right arch, emit and proc files
|
||||
# Choose the right machine-dependent files
|
||||
|
||||
asmcomp\arch.ml: asmcomp\arch_$(ARCH).ml
|
||||
cp asmcomp\arch_$(ARCH).ml asmcomp\arch.ml
|
||||
asmcomp\arch.ml: asmcomp\$(ARCH)\arch.ml
|
||||
cp $(ARCH)\arch.ml asmcomp\arch.ml
|
||||
|
||||
partialclean::
|
||||
rm -f asmcomp\arch.ml
|
||||
|
||||
beforedepend:: asmcomp\arch.ml
|
||||
|
||||
asmcomp\proc.ml: asmcomp\proc_$(ARCH)nt.ml
|
||||
cp asmcomp\proc_$(ARCH)nt.ml asmcomp\proc.ml
|
||||
asmcomp\proc.ml: asmcomp\$(ARCH)\proc_nt.ml
|
||||
cp $(ARCH)\proc_nt.ml asmcomp\proc.ml
|
||||
|
||||
partialclean::
|
||||
rm -f asmcomp\proc.ml
|
||||
|
||||
beforedepend:: asmcomp\proc.ml
|
||||
|
||||
asmcomp\selection.ml: asmcomp\$(ARCH)\selection.ml
|
||||
cp $(ARCH)\selection.ml asmcomp\selection.ml
|
||||
|
||||
partialclean::
|
||||
rm -f asmcomp\selection.ml
|
||||
|
||||
beforedepend:: asmcomp\selection.ml
|
||||
|
||||
asmcomp\reload.ml: asmcomp\$(ARCH)\reload.ml
|
||||
cp $(ARCH)\reload.ml asmcomp\reload.ml
|
||||
|
||||
partialclean::
|
||||
rm -f asmcomp\reload.ml
|
||||
|
||||
beforedepend:: asmcomp\reload.ml
|
||||
|
||||
asmcomp\scheduling.ml: asmcomp\$(ARCH)\scheduling.ml
|
||||
cp $(ARCH)\scheduling.ml asmcomp\scheduling.ml
|
||||
|
||||
partialclean::
|
||||
rm -f asmcomp\scheduling.ml
|
||||
|
||||
beforedepend:: asmcomp\scheduling.ml
|
||||
|
||||
# Preprocess the code emitters
|
||||
|
||||
asmcomp\emit.ml: asmcomp\emit_$(ARCH)nt.mlp tools\cvt_emit
|
||||
boot\ocamlrun tools\cvt_emit < asmcomp\emit_$(ARCH)nt.mlp > asmcomp\emit.ml
|
||||
asmcomp\emit.ml: asmcomp\$(ARCH)\emit_nt.mlp tools\cvt_emit
|
||||
boot\ocamlrun tools\cvt_emit < asmcomp\$(ARCH)\emit_nt.mlp > asmcomp\emit.ml
|
||||
|
||||
partialclean::
|
||||
rm -f asmcomp\emit.ml
|
||||
|
|
|
|||
|
|
@ -19,56 +19,8 @@ open Reg
|
|||
open Arch
|
||||
open Mach
|
||||
|
||||
(* Exceptions raised to signal cases not handled here *)
|
||||
|
||||
exception Use_default
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
let select_addressing = function
|
||||
Cconst_symbol s ->
|
||||
(Ibased(s, 0), Ctuple [])
|
||||
| Cop(Cadda, [Cconst_symbol s; Cconst_int n]) ->
|
||||
(Ibased(s, n), Ctuple [])
|
||||
| Cop(Cadda, [arg; Cconst_int n]) ->
|
||||
(Iindexed n, arg)
|
||||
| Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) ->
|
||||
(Iindexed n, Cop(Cadda, [arg1; arg2]))
|
||||
| arg ->
|
||||
(Iindexed 0, arg)
|
||||
|
||||
let select_oper op args =
|
||||
match (op, args) with
|
||||
((Caddi|Cadda),
|
||||
[arg2; Cop(Clsl, [arg1; Cconst_int(2|3 as shift)])]) ->
|
||||
(Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| ((Caddi|Cadda),
|
||||
[arg2; Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)])]) ->
|
||||
(Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| ((Caddi|Cadda),
|
||||
[arg2; Cop(Cmuli, [Cconst_int(4|8 as mult); arg1])]) ->
|
||||
(Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| (Caddi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) ->
|
||||
(Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| (Caddi, [Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)]); arg2]) ->
|
||||
(Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| (Caddi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) ->
|
||||
(Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| (Csubi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) ->
|
||||
(Ispecific(if shift = 2 then Isub4 else Isub8), [arg1; arg2])
|
||||
| (Csubi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) ->
|
||||
(Ispecific(if mult = 4 then Isub4 else Isub8), [arg1; arg2])
|
||||
| _ ->
|
||||
raise Use_default
|
||||
|
||||
let select_store addr exp = raise Use_default
|
||||
|
||||
let select_push exp = fatal_error "Proc: select_push"
|
||||
|
||||
let pseudoregs_for_operation op arg res = raise Use_default
|
||||
|
||||
let is_immediate (n:int) = true
|
||||
|
||||
let word_addressed = true
|
||||
|
||||
(* Registers available for register allocation *)
|
||||
|
|
@ -245,17 +197,6 @@ let max_register_pressure = function
|
|||
Iextcall(_, _) -> [| 4; 8 |]
|
||||
| _ -> [| 19; 29 |]
|
||||
|
||||
(* Reloading *)
|
||||
|
||||
let reload_test makereg round tst args = raise Use_default
|
||||
let reload_operation makereg round op args res = raise Use_default
|
||||
|
||||
(* No scheduling is needed, the assembler does it better than us. *)
|
||||
|
||||
let need_scheduling = false
|
||||
|
||||
let oper_latency _ = 1
|
||||
|
||||
(* Layout of the stack *)
|
||||
|
||||
let num_stack_slots = [| 0; 0 |]
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Reloading for the Alpha *)
|
||||
|
||||
let fundecl f =
|
||||
(new Reloadgen.reload_generic ())#fundecl f
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Schedgen (* to create a dependency *)
|
||||
|
||||
(* No scheduling is needed for the Alpha, the Digital Unix assembler
|
||||
does it better than us. Problem: the assembler for Linux-Alpha
|
||||
does not do scheduling... *)
|
||||
|
||||
let fundecl f = f
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1997 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Instruction selection for the Alpha processor *)
|
||||
|
||||
open Misc
|
||||
open Cmm
|
||||
open Reg
|
||||
open Arch
|
||||
open Mach
|
||||
|
||||
class selector () as self =
|
||||
|
||||
inherit Selectgen.selector_generic() as super
|
||||
|
||||
method is_immediate (n : int) = true
|
||||
|
||||
method select_addressing = function
|
||||
Cconst_symbol s ->
|
||||
(Ibased(s, 0), Ctuple [])
|
||||
| Cop(Cadda, [Cconst_symbol s; Cconst_int n]) ->
|
||||
(Ibased(s, n), Ctuple [])
|
||||
| Cop(Cadda, [arg; Cconst_int n]) ->
|
||||
(Iindexed n, arg)
|
||||
| Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) ->
|
||||
(Iindexed n, Cop(Cadda, [arg1; arg2]))
|
||||
| arg ->
|
||||
(Iindexed 0, arg)
|
||||
|
||||
method select_operation op args =
|
||||
match (op, args) with
|
||||
((Caddi|Cadda),
|
||||
[arg2; Cop(Clsl, [arg1; Cconst_int(2|3 as shift)])]) ->
|
||||
(Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| ((Caddi|Cadda),
|
||||
[arg2; Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)])]) ->
|
||||
(Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| ((Caddi|Cadda),
|
||||
[arg2; Cop(Cmuli, [Cconst_int(4|8 as mult); arg1])]) ->
|
||||
(Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| (Caddi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) ->
|
||||
(Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| (Caddi, [Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)]); arg2]) ->
|
||||
(Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| (Caddi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) ->
|
||||
(Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
|
||||
| (Csubi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) ->
|
||||
(Ispecific(if shift = 2 then Isub4 else Isub8), [arg1; arg2])
|
||||
| (Csubi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) ->
|
||||
(Ispecific(if mult = 4 then Isub4 else Isub8), [arg1; arg2])
|
||||
| _ ->
|
||||
super#select_operation op args
|
||||
|
||||
end
|
||||
|
||||
let fundecl f = (new selector ())#emit_fundecl f
|
||||
|
|
@ -47,7 +47,7 @@ let rec regalloc round fd =
|
|||
if !dump_prefer then Printmach.preferences();
|
||||
Coloring.allocate_registers();
|
||||
dump_if dump_regalloc "After register allocation" fd;
|
||||
let (newfd, redo_regalloc) = Reload.fundecl round fd in
|
||||
let (newfd, redo_regalloc) = Reload.fundecl fd in
|
||||
dump_if dump_reload "After insertion of reloading code" newfd;
|
||||
if redo_regalloc
|
||||
then begin Reg.reinit(); Liveness.fundecl newfd; regalloc (round+1) newfd end
|
||||
|
|
|
|||
|
|
@ -1,661 +0,0 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* 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 symbol *)
|
||||
|
||||
let emit_symbol s =
|
||||
Emitaux.emit_symbol '$' s
|
||||
|
||||
(* 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"
|
||||
|
||||
(* Layout of the stack frame *)
|
||||
|
||||
let stack_offset = ref 0
|
||||
let uses_gp = ref false
|
||||
|
||||
let frame_size () =
|
||||
let size =
|
||||
!stack_offset +
|
||||
8 * (num_stack_slots.(0) + num_stack_slots.(1)) +
|
||||
(if !contains_calls then 8 else 0) +
|
||||
(if !uses_gp then 8 else 0) in
|
||||
Misc.align size 16
|
||||
|
||||
let slot_offset loc cl =
|
||||
match loc with
|
||||
Incoming n -> frame_size() + n
|
||||
| Local n ->
|
||||
if cl = 0
|
||||
then !stack_offset + n * 8
|
||||
else !stack_offset + (num_stack_slots.(0) + n) * 8
|
||||
| Outgoing n -> n
|
||||
|
||||
(* 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, ofs) ->
|
||||
`{emit_symbol s}`;
|
||||
if ofs > 0 then ` + {emit_int ofs}`;
|
||||
if ofs < 0 then ` - {emit_int(-ofs)}`
|
||||
|
||||
(* Communicate live registers at call points to the assembler *)
|
||||
|
||||
let int_reg_number = [|
|
||||
0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12;
|
||||
16; 17; 18; 19; 20; 21; 22
|
||||
|]
|
||||
|
||||
let float_reg_number = [|
|
||||
0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15;
|
||||
16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 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_26 = 1 lsl (31 - 26)
|
||||
let live_27 = 1 lsl (31 - 27)
|
||||
|
||||
(* 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 := ((int_reg_number.(r) lsl 1) + 1) :: !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`;
|
||||
` .word {emit_int fd.fd_frame_size}\n`;
|
||||
` .word {emit_int (List.length fd.fd_live_offset)}\n`;
|
||||
List.iter
|
||||
(fun n ->
|
||||
` .word {emit_int n}\n`)
|
||||
fd.fd_live_offset;
|
||||
` .align 3\n`
|
||||
|
||||
(* 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_frame: label; (* Label of frame descriptor *)
|
||||
gc_instr: instruction } (* Record live registers *)
|
||||
|
||||
let call_gc_sites = ref ([] : gc_call list)
|
||||
|
||||
let emit_call_gc gc =
|
||||
`{emit_label gc.gc_lbl}:`;
|
||||
liveregs gc.gc_instr 0;
|
||||
`{emit_label gc.gc_frame}: bsr caml_call_gc\n`;
|
||||
` br {emit_label gc.gc_return_lbl}\n`
|
||||
|
||||
(* Determine if $gp is used in the function *)
|
||||
|
||||
let rec instr_uses_gp i =
|
||||
match i.desc with
|
||||
Lend -> false
|
||||
| Lop(Iconst_int n) ->
|
||||
if Nativeint.cmp n (-0x8000000) < 0 || Nativeint.cmp n 0x7FFFFFFF > 0
|
||||
then true else instr_uses_gp i.next
|
||||
| Lop(Iconst_float s) -> true
|
||||
| Lop(Iconst_symbol s) -> true
|
||||
| Lop(Iextcall(_, _)) -> true
|
||||
| Lop(Iload(_, Ibased(_, _))) -> true
|
||||
| Lop(Istore(_, Ibased(_, _))) -> true
|
||||
| Lop(Iintop(Idiv | Imod)) -> true (* divq and remq can be turned into *)
|
||||
| Lop(Iintop_imm((Idiv | Imod), _)) -> true (* a function call *)
|
||||
| Lop(Iintop_imm(_, n)) ->
|
||||
if n < -0x8000000 || n > 0x7FFFFFFF then true else instr_uses_gp i.next
|
||||
| Lsetuptrap lbl -> true
|
||||
| _ ->
|
||||
instr_uses_gp i.next
|
||||
|
||||
(* 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"
|
||||
| _ -> Misc.fatal_error "Emit.name_for_int_operation"
|
||||
|
||||
let name_for_float_operation = function
|
||||
Inegf -> "fneg"
|
||||
| Iabsf -> "fabs"
|
||||
| Iaddf -> "addt"
|
||||
| Isubf -> "subt"
|
||||
| Imulf -> "mult"
|
||||
| Idivf -> "divt"
|
||||
| _ -> Misc.fatal_error "Emit.name_for_float_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 cmp neg =
|
||||
match cmp with
|
||||
Ceq -> ("cmpteq", false, neg) | Cne -> ("cmpteq", false, not neg)
|
||||
| Cle -> ("cmptle", false, neg) | Cgt -> ("cmptlt", true, neg)
|
||||
| Clt -> ("cmptlt", false, neg) | Cge -> ("cmptle", true, neg)
|
||||
|
||||
(* Output the assembly code for an instruction *)
|
||||
|
||||
(* Name of current function *)
|
||||
let function_name = ref ""
|
||||
(* Entry point for tail recursive calls *)
|
||||
let tailrec_entry_point = ref 0
|
||||
(* Label of trap for out-of-range accesses *)
|
||||
let range_check_trap = ref 0
|
||||
|
||||
let emit_instr i =
|
||||
match i.desc with
|
||||
Lend -> ()
|
||||
| Lop(Imove | Ispill | Ireload) ->
|
||||
let src = i.arg.(0) and dst = i.res.(0) in
|
||||
if src.loc <> dst.loc then begin
|
||||
match (src.loc, dst.loc) with
|
||||
(Reg rs, Reg rd) ->
|
||||
if src.typ = Float then
|
||||
` fmov {emit_reg src}, {emit_reg dst}\n`
|
||||
else
|
||||
` mov {emit_reg src}, {emit_reg dst}\n`
|
||||
| (Reg rs, Stack sd) ->
|
||||
if src.typ = Float then
|
||||
` stt {emit_reg src}, {emit_stack dst}\n`
|
||||
else
|
||||
` stq {emit_reg src}, {emit_stack dst}\n`
|
||||
| (Stack ss, Reg rd) ->
|
||||
if src.typ = Float then
|
||||
` ldt {emit_reg dst}, {emit_stack src}\n`
|
||||
else
|
||||
` ldq {emit_reg dst}, {emit_stack src}\n`
|
||||
| _ ->
|
||||
fatal_error "Emit_alpha: Imove"
|
||||
end
|
||||
| Lop(Iconst_int n) ->
|
||||
if Nativeint.sign n = 0 then
|
||||
` clr {emit_reg i.res.(0)}\n`
|
||||
else
|
||||
` ldiq {emit_reg i.res.(0)}, {emit_nativeint n}\n`
|
||||
| Lop(Iconst_float s) ->
|
||||
` ldit {emit_reg i.res.(0)}, {emit_string s}\n`
|
||||
| Lop(Iconst_symbol s) ->
|
||||
` lda {emit_reg i.res.(0)}, {emit_symbol s}\n`
|
||||
| Lop(Icall_ind) ->
|
||||
liveregs i 0;
|
||||
`{record_frame i.live} jsr ({emit_reg i.arg.(0)})\n`
|
||||
| Lop(Icall_imm s) ->
|
||||
liveregs i 0;
|
||||
`{record_frame i.live} bsr {emit_symbol s}\n`
|
||||
| Lop(Itailcall_ind) ->
|
||||
let n = frame_size() in
|
||||
if !contains_calls then
|
||||
` ldq $26, {emit_int(n - 8)}($sp)\n`;
|
||||
if !uses_gp then
|
||||
` ldq $gp, {emit_int(n - 16)}($sp)\n`;
|
||||
if n > 0 then
|
||||
` lda $sp, {emit_int n}($sp)\n`;
|
||||
liveregs i live_26;
|
||||
` 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 !uses_gp then
|
||||
` ldq $gp, {emit_int(n - 16)}($sp)\n`;
|
||||
if n > 0 then
|
||||
` lda $sp, {emit_int n}($sp)\n`;
|
||||
liveregs i live_26;
|
||||
` br {emit_symbol s}\n`
|
||||
end
|
||||
| Lop(Iextcall(s, alloc)) ->
|
||||
if alloc then begin
|
||||
` lda $27, {emit_symbol s}\n`;
|
||||
liveregs i live_27;
|
||||
`{record_frame i.live} bsr caml_c_call\n`
|
||||
(* caml_c_call preserves $gp *)
|
||||
end else begin
|
||||
` jsr {emit_symbol s}\n`;
|
||||
if !uses_gp then
|
||||
` ldgp $gp, 0($26)\n`
|
||||
end
|
||||
| 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_redo = new_label() in
|
||||
`{emit_label lbl_redo}: subq $13, {emit_int n}, $13\n`;
|
||||
` cmpult $13, $14, $25\n`;
|
||||
let lbl_call_gc = new_label() in
|
||||
let lbl_frame = 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_redo;
|
||||
gc_frame = lbl_frame;
|
||||
gc_instr = i } :: !call_gc_sites;
|
||||
` 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(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(Icheckbound)) ->
|
||||
if !range_check_trap = 0 then range_check_trap := new_label();
|
||||
` cmpule {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`;
|
||||
` bne $25, {emit_label !range_check_trap}\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(Idiv, n)) when n = 1 lsl (Misc.log2 n) ->
|
||||
let l = Misc.log2 n in
|
||||
` addq {emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n`;
|
||||
` cmovge {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, $25\n`;
|
||||
` sra $25, {emit_int l}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Iintop_imm(Imod, n)) when n = 1 lsl (Misc.log2 n) ->
|
||||
let l = Misc.log2 n in
|
||||
` and {emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n`;
|
||||
` subq $25, {emit_int n}, $24\n`;
|
||||
` cmovge {emit_reg i.arg.(0)}, $25, $24\n`;
|
||||
` cmoveq $25, $25, $24\n`;
|
||||
` mov $24, {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(Icheckbound, n)) ->
|
||||
if !range_check_trap = 0 then range_check_trap := new_label();
|
||||
` cmpule {emit_reg i.arg.(0)}, {emit_int n}, $25\n`;
|
||||
` bne $25, {emit_label !range_check_trap}\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(Inegf | Iabsf as op) ->
|
||||
let instr = name_for_float_operation op in
|
||||
` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
|
||||
let instr = name_for_float_operation op in
|
||||
` {emit_string instr} {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(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`
|
||||
| Lreloadretaddr ->
|
||||
let n = frame_size() in
|
||||
` ldq $26, {emit_int(n - 8)}($sp)\n`
|
||||
| Lreturn ->
|
||||
let n = frame_size() in
|
||||
if !uses_gp then
|
||||
` ldq $gp, {emit_int(n - 16)}($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
|
||||
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, neg) ->
|
||||
let (comp, swap, test) = name_for_float_comparison cmp neg in
|
||||
` {emit_string comp} `;
|
||||
if swap
|
||||
then `{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, $f30\n`
|
||||
else `{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $f30\n`;
|
||||
if test
|
||||
then ` fbeq $f30, {emit_label lbl}\n`
|
||||
else ` fbne $f30, {emit_label lbl}\n`
|
||||
| Ioddtest ->
|
||||
` blbs {emit_reg i.arg.(0)}, {emit_label lbl}\n`
|
||||
| Ieventest ->
|
||||
` blbc {emit_reg i.arg.(0)}, {emit_label lbl}\n`
|
||||
end
|
||||
| Lcondbranch3(lbl0, lbl1, lbl2) ->
|
||||
begin match lbl0 with
|
||||
None -> ()
|
||||
| Some lbl -> ` beq {emit_reg i.arg.(0)}, {emit_label lbl}\n`
|
||||
end;
|
||||
begin match lbl1 with
|
||||
None -> ()
|
||||
| Some lbl -> ` blbs {emit_reg i.arg.(0)}, {emit_label lbl}\n`
|
||||
end;
|
||||
begin match lbl2 with
|
||||
None -> ()
|
||||
| Some lbl ->
|
||||
if lbl0 <> None then
|
||||
` blbc {emit_reg i.arg.(0)}, {emit_label lbl}\n`
|
||||
else if lbl1 <> None then
|
||||
` bne {emit_reg i.arg.(0)}, {emit_label lbl}\n`
|
||||
else begin
|
||||
` subq {emit_reg i.arg.(0)}, 2, $25\n`;
|
||||
` beq $25, {emit_label lbl}\n`
|
||||
end
|
||||
end
|
||||
| Lswitch jumptbl ->
|
||||
let lbl_jump = new_label() in
|
||||
` br $25, {emit_label lbl_jump}\n`;
|
||||
for i = 0 to Array.length jumptbl - 1 do
|
||||
` br {emit_label jumptbl.(i)}\n`
|
||||
done;
|
||||
`{emit_label lbl_jump}: s4addq {emit_reg i.arg.(0)}, $25, $25\n`;
|
||||
` jmp ($25)\n`
|
||||
| Lsetuptrap lbl ->
|
||||
` br $25, {emit_label lbl}\n`;
|
||||
if !uses_gp then
|
||||
` ldgp $gp, 0($27)\n`
|
||||
| Lpushtrap ->
|
||||
stack_offset := !stack_offset + 16;
|
||||
` lda $sp, -16($sp)\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
|
||||
| Lraise ->
|
||||
` mov $15, $sp\n`;
|
||||
` ldq $15, 0($sp)\n`;
|
||||
` ldq $27, 8($sp)\n`;
|
||||
` lda $sp, 16($sp)\n`;
|
||||
liveregs i 0;
|
||||
` jmp $25, ($27)\n` (* Keep retaddr in $25 for debugging *)
|
||||
|
||||
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;
|
||||
fastcode_flag := fundecl.fun_fast;
|
||||
tailrec_entry_point := new_label();
|
||||
stack_offset := 0;
|
||||
call_gc_sites := [];
|
||||
uses_gp := instr_uses_gp fundecl.fun_body;
|
||||
if !uses_gp then contains_calls := true;
|
||||
range_check_trap := 0;
|
||||
` .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`;
|
||||
let n = frame_size() in
|
||||
if n > 0 then
|
||||
` lda $sp, -{emit_int n}($sp)\n`;
|
||||
if !uses_gp then begin
|
||||
let lbl = new_label() in
|
||||
` br $27, {emit_label lbl}\n`;
|
||||
`{emit_label lbl}: stq $gp, {emit_int(n - 16)}($sp)\n`;
|
||||
` ldgp $gp, 4($27)\n`
|
||||
end;
|
||||
if !contains_calls then begin
|
||||
` stq $26, {emit_int(n - 8)}($sp)\n`;
|
||||
` .mask 0x04000000, -8\n`;
|
||||
` .fmask 0x0, 0\n`
|
||||
end;
|
||||
` .frame $sp, {emit_int n}, $26\n`;
|
||||
` .prologue {emit_int(if !uses_gp then 1 else 0)}\n`;
|
||||
`{emit_label !tailrec_entry_point}:\n`;
|
||||
emit_all fundecl.fun_body;
|
||||
List.iter emit_call_gc !call_gc_sites;
|
||||
if !range_check_trap > 0 then
|
||||
`{emit_label !range_check_trap}: br $25, call_array_bound_error\n`;
|
||||
` .end {emit_symbol fundecl.fun_name}\n`
|
||||
|
||||
(* Emission of data *)
|
||||
|
||||
let emit_item = function
|
||||
Cdefine_symbol s ->
|
||||
` .globl {emit_symbol s}\n`;
|
||||
`{emit_symbol s}:\n`
|
||||
| Cdefine_label lbl ->
|
||||
`{emit_label (10000 + lbl)}:\n`
|
||||
| Cint8 n ->
|
||||
` .byte {emit_int n}\n`
|
||||
| Cint16 n ->
|
||||
` .word {emit_int n}\n`
|
||||
| Cint n ->
|
||||
` .quad {emit_nativeint n}\n`
|
||||
| Cfloat f ->
|
||||
` .double {emit_string f}\n`
|
||||
| Csymbol_address s ->
|
||||
` .quad {emit_symbol s}\n`
|
||||
| Clabel_address lbl ->
|
||||
` .quad {emit_label (10000 + lbl)}\n`
|
||||
| Cstring s ->
|
||||
emit_string_directive " .ascii " s
|
||||
| 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() =
|
||||
(* There are really two groups of registers:
|
||||
$sp and $15 always point to stack locations
|
||||
$0 - $14, $16-$23 never point to stack locations. *)
|
||||
` .noalias $0,$sp; .noalias $0,$15; .noalias $1,$sp; .noalias $1,$15\n`;
|
||||
` .noalias $2,$sp; .noalias $2,$15; .noalias $3,$sp; .noalias $3,$15\n`;
|
||||
` .noalias $4,$sp; .noalias $4,$15; .noalias $5,$sp; .noalias $5,$15\n`;
|
||||
` .noalias $6,$sp; .noalias $6,$15; .noalias $7,$sp; .noalias $7,$15\n`;
|
||||
` .noalias $8,$sp; .noalias $8,$15; .noalias $9,$sp; .noalias $9,$15\n`;
|
||||
` .noalias $10,$sp; .noalias $10,$15; .noalias $11,$sp; .noalias $11,$15\n`;
|
||||
` .noalias $12,$sp; .noalias $12,$15; .noalias $13,$sp; .noalias $13,$15\n`;
|
||||
` .noalias $14,$sp; .noalias $14,$15; .noalias $16,$sp; .noalias $16,$15\n`;
|
||||
` .noalias $17,$sp; .noalias $17,$15; .noalias $18,$sp; .noalias $18,$15\n`;
|
||||
` .noalias $19,$sp; .noalias $19,$15; .noalias $20,$sp; .noalias $20,$15\n`;
|
||||
` .noalias $21,$sp; .noalias $21,$15; .noalias $22,$sp; .noalias $22,$15\n`;
|
||||
` .noalias $23,$sp; .noalias $23,$15\n\n`;
|
||||
(* The following .file directive is intended to prevent the generation
|
||||
of line numbers for the debugger, 'cos they make .o files larger
|
||||
and slow down linking. *)
|
||||
` .file 1 \"{emit_string !Location.input_name}\"\n\n`;
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
|
||||
` .data\n`;
|
||||
` .globl {emit_symbol lbl_begin}\n`;
|
||||
`{emit_symbol lbl_begin}:\n`;
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
|
||||
` .text\n`;
|
||||
` .globl {emit_symbol lbl_begin}\n`;
|
||||
`{emit_symbol lbl_begin}:\n`
|
||||
|
||||
let end_assembly () =
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
|
||||
` .text\n`;
|
||||
` .globl {emit_symbol lbl_end}\n`;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
|
||||
` .data\n`;
|
||||
` .globl {emit_symbol lbl_end}\n`;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
` .quad 0\n`;
|
||||
let lbl_frame = Compilenv.current_unit_name() ^ "_frametable" in
|
||||
` .rdata\n`;
|
||||
` .globl {emit_symbol lbl_frame}\n`;
|
||||
`{emit_symbol lbl_frame}:\n`;
|
||||
` .quad {emit_int (List.length !frame_descriptors)}\n`;
|
||||
List.iter emit_frame !frame_descriptors;
|
||||
frame_descriptors := []
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,799 +0,0 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* 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
|
||||
|
||||
let stack_offset = ref 0
|
||||
|
||||
(* Layout of the stack frame *)
|
||||
|
||||
let frame_size () = (* includes return address *)
|
||||
!stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4
|
||||
|
||||
let slot_offset loc cl =
|
||||
match loc with
|
||||
Incoming n -> frame_size() + n
|
||||
| Local n ->
|
||||
if cl = 0
|
||||
then !stack_offset + n * 4
|
||||
else !stack_offset + num_stack_slots.(0) * 4 + n * 8
|
||||
| Outgoing n -> n
|
||||
|
||||
(* Symbols are prefixed with _, except under Linux with ELF binaries *)
|
||||
|
||||
let symbol_prefix =
|
||||
match Config.system with
|
||||
"linux_elf" -> ""
|
||||
| "solaris" -> ""
|
||||
| _ -> "_"
|
||||
|
||||
let emit_symbol s =
|
||||
emit_string symbol_prefix; Emitaux.emit_symbol '$' s
|
||||
|
||||
(* Output a label *)
|
||||
|
||||
let label_prefix =
|
||||
match Config.system with
|
||||
"linux_elf" -> ".L"
|
||||
| "solaris" -> ".L"
|
||||
| _ -> "L"
|
||||
|
||||
let emit_label lbl =
|
||||
emit_string label_prefix; emit_int lbl
|
||||
|
||||
(* Some data directives have different names under Solaris *)
|
||||
|
||||
let word_dir =
|
||||
match Config.system with
|
||||
"solaris" -> ".value"
|
||||
| _ -> ".word"
|
||||
let skip_dir =
|
||||
match Config.system with
|
||||
"solaris" -> ".zero"
|
||||
| _ -> ".space"
|
||||
let use_ascii_dir =
|
||||
match Config.system with
|
||||
"solaris" -> false
|
||||
| _ -> true
|
||||
|
||||
(* Output a .align directive.
|
||||
The numerical argument to .align is log2 of alignment size, except
|
||||
under ELF, where it is the alignment size... *)
|
||||
|
||||
let emit_align =
|
||||
match Config.system with
|
||||
"linux_elf" | "solaris" ->
|
||||
(fun n -> ` .align {emit_int n}\n`)
|
||||
| _ ->
|
||||
(fun n -> ` .align {emit_int(Misc.log2 n)}\n`)
|
||||
|
||||
(* Output a pseudo-register *)
|
||||
|
||||
let emit_reg = function
|
||||
{ loc = Reg r } ->
|
||||
emit_string (register_name r)
|
||||
| { loc = Stack s } as r ->
|
||||
let ofs = slot_offset s (register_class r) in
|
||||
`{emit_int ofs}(%esp)`
|
||||
| { loc = Unknown } ->
|
||||
fatal_error "Emit_i386.emit_reg"
|
||||
|
||||
(* Output a reference to the lower 8 bits or lower 16 bits of a register *)
|
||||
|
||||
let reg_low_byte_name = [| "%al"; "%bl"; "%cl"; "%dl" |]
|
||||
let reg_low_half_name = [| "%ax"; "%bx"; "%cx"; "%dx"; "%si"; "%di"; "%bp" |]
|
||||
|
||||
let emit_reg8 r =
|
||||
match r.loc with
|
||||
Reg r when r < 4 -> emit_string (reg_low_byte_name.(r))
|
||||
| _ -> fatal_error "Emit_i386.emit_reg8"
|
||||
|
||||
let emit_reg16 r =
|
||||
match r.loc with
|
||||
Reg r when r < 7 -> emit_string (reg_low_half_name.(r))
|
||||
| _ -> fatal_error "Emit_i386.emit_reg16"
|
||||
|
||||
(* Check if the given register overlaps (same location) with the given
|
||||
array of registers *)
|
||||
|
||||
let register_overlap reg arr =
|
||||
try
|
||||
for i = 0 to Array.length arr - 1 do
|
||||
if reg.loc = arr.(i).loc then raise Exit
|
||||
done;
|
||||
false
|
||||
with Exit ->
|
||||
true
|
||||
|
||||
(* 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)})`
|
||||
| Iscaled(scale, d) ->
|
||||
if d <> 0 then emit_int d;
|
||||
`(, {emit_reg r.(n)}, {emit_int scale})`
|
||||
| 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_label live =
|
||||
let lbl = new_label() in
|
||||
let live_offset = ref [] in
|
||||
Reg.Set.iter
|
||||
(function
|
||||
{typ = Addr; loc = Reg r} ->
|
||||
live_offset := ((r lsl 1) + 1) :: !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}:\n`
|
||||
|
||||
let emit_frame fd =
|
||||
` .long {emit_label fd.fd_lbl}\n`;
|
||||
` {emit_string word_dir} {emit_int fd.fd_frame_size}\n`;
|
||||
` {emit_string word_dir} {emit_int (List.length fd.fd_live_offset)}\n`;
|
||||
List.iter
|
||||
(fun n ->
|
||||
` {emit_string word_dir} {emit_int n}\n`)
|
||||
fd.fd_live_offset;
|
||||
emit_align 4
|
||||
|
||||
(* 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_frame: label } (* Label of frame descriptor *)
|
||||
|
||||
let call_gc_sites = ref ([] : gc_call list)
|
||||
|
||||
let emit_call_gc gc =
|
||||
`{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`;
|
||||
`{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n`
|
||||
|
||||
(* Names for instructions *)
|
||||
|
||||
let instr_for_intop = function
|
||||
Iadd -> "addl"
|
||||
| Isub -> "subl"
|
||||
| Imul -> "imull"
|
||||
| Iand -> "andl"
|
||||
| Ior -> "orl"
|
||||
| Ixor -> "xorl"
|
||||
| Ilsl -> "sall"
|
||||
| Ilsr -> "shrl"
|
||||
| Iasr -> "sarl"
|
||||
| _ -> fatal_error "Emit_i386: instr_for_intop"
|
||||
|
||||
let instr_for_floatop = function
|
||||
Inegf -> "fchs"
|
||||
| Iabsf -> "fabs"
|
||||
| Iaddf -> "faddl"
|
||||
| Isubf -> "fsubl"
|
||||
| Imulf -> "fmull"
|
||||
| Idivf -> "fdivl"
|
||||
| Ispecific Isubfrev -> "fsubrl"
|
||||
| Ispecific Idivfrev -> "fdivrl"
|
||||
| _ -> fatal_error "Emit_i386: instr_for_floatop"
|
||||
|
||||
let instr_for_floatop_reversed = function
|
||||
Iaddf -> "faddl"
|
||||
| Isubf -> "fsubrl"
|
||||
| Imulf -> "fmull"
|
||||
| Idivf -> "fdivrl"
|
||||
| Ispecific Isubfrev -> "fsubl"
|
||||
| Ispecific Idivfrev -> "fdivl"
|
||||
| _ -> fatal_error "Emit_i386: instr_for_floatop_reversed"
|
||||
|
||||
let instr_for_floatop_pop = function
|
||||
Iaddf -> "faddp"
|
||||
| Isubf -> "fsubp"
|
||||
| Imulf -> "fmulp"
|
||||
| Idivf -> "fdivp"
|
||||
| Ispecific Isubfrev -> "fsubrp"
|
||||
| Ispecific Idivfrev -> "fdivrp"
|
||||
| _ -> fatal_error "Emit_i386: instr_for_floatop_pop"
|
||||
|
||||
let instr_for_floatarithmem = function
|
||||
Ifloatadd -> "faddl"
|
||||
| Ifloatsub -> "fsubl"
|
||||
| Ifloatsubrev -> "fsubrl"
|
||||
| Ifloatmul -> "fmull"
|
||||
| Ifloatdiv -> "fdivl"
|
||||
| Ifloatdivrev -> "fdivrl"
|
||||
|
||||
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 an = 0 or <> 0 test. *)
|
||||
|
||||
let output_test_zero arg =
|
||||
match arg.loc with
|
||||
Reg r -> ` testl {emit_reg arg}, {emit_reg arg}\n`
|
||||
| _ -> ` cmpl $0, {emit_reg arg}\n`
|
||||
|
||||
(* Deallocate the stack frame before a return or tail call *)
|
||||
|
||||
let output_epilogue () =
|
||||
let n = frame_size() - 4 in
|
||||
if n > 0 then ` addl ${emit_int n}, %esp\n`
|
||||
|
||||
(* Output the assembly code for an instruction *)
|
||||
|
||||
(* Name of current function *)
|
||||
let function_name = ref ""
|
||||
(* Entry point for tail recursive calls *)
|
||||
let tailrec_entry_point = ref 0
|
||||
(* Label of trap for out-of-range accesses *)
|
||||
let range_check_trap = ref 0
|
||||
|
||||
let float_constants = ref ([] : (int * string) list)
|
||||
|
||||
let tos = phys_reg 100
|
||||
|
||||
let emit_instr i =
|
||||
match i.desc with
|
||||
Lend -> ()
|
||||
| Lop(Imove | Ispill | Ireload) ->
|
||||
let src = i.arg.(0) and dst = i.res.(0) in
|
||||
if src.loc <> dst.loc then begin
|
||||
if src.typ = Float then
|
||||
if src = tos then
|
||||
` fstpl {emit_reg dst}\n`
|
||||
else begin
|
||||
` fldl {emit_reg src}\n`;
|
||||
` fstpl {emit_reg dst}\n`
|
||||
end
|
||||
else
|
||||
` movl {emit_reg src}, {emit_reg dst}\n`
|
||||
end
|
||||
| Lop(Iconst_int n) ->
|
||||
if Nativeint.sign n = 0 then 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 else
|
||||
` movl ${emit_nativeint n}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Iconst_float s) ->
|
||||
let f = float_of_string s in
|
||||
if f = 0.0 then
|
||||
` fldz\n`
|
||||
else if f = 1.0 then
|
||||
` fld1\n`
|
||||
else begin
|
||||
let lbl = new_label() in
|
||||
float_constants := (lbl, s) :: !float_constants;
|
||||
` fldl {emit_label lbl}\n`
|
||||
end
|
||||
| Lop(Iconst_symbol s) ->
|
||||
` movl ${emit_symbol s}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Icall_ind) ->
|
||||
` call *{emit_reg i.arg.(0)}\n`;
|
||||
record_frame i.live
|
||||
| Lop(Icall_imm s) ->
|
||||
` call {emit_symbol s}\n`;
|
||||
record_frame i.live
|
||||
| Lop(Itailcall_ind) ->
|
||||
output_epilogue();
|
||||
` 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
|
||||
output_epilogue();
|
||||
` jmp {emit_symbol s}\n`
|
||||
end
|
||||
| Lop(Iextcall(s, alloc)) ->
|
||||
if alloc then begin
|
||||
` movl ${emit_symbol s}, %eax\n`;
|
||||
` call {emit_symbol "caml_c_call"}\n`;
|
||||
record_frame i.live
|
||||
end else begin
|
||||
` call {emit_symbol s}\n`
|
||||
end
|
||||
| Lop(Istackoffset n) ->
|
||||
if n < 0
|
||||
then ` addl ${emit_int(-n)}, %esp\n`
|
||||
else ` subl ${emit_int(n)}, %esp\n`;
|
||||
stack_offset := !stack_offset + n
|
||||
| Lop(Iload(chunk, addr)) ->
|
||||
let dest = i.res.(0) in
|
||||
begin match dest.typ with
|
||||
Int | Addr ->
|
||||
begin match (chunk, dest.loc) with
|
||||
(Word, _) ->
|
||||
` movl {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
| (Byte_unsigned, Reg r) when r < 4 & not (register_overlap dest i.arg) ->
|
||||
` xorl {emit_reg dest}, {emit_reg dest}\n`;
|
||||
` movb {emit_addressing addr i.arg 0}, {emit_reg8 dest}\n`
|
||||
| (Byte_unsigned, _) ->
|
||||
` movzbl {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
| (Byte_signed, _) ->
|
||||
` movsbl {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
| (Sixteen_unsigned, Reg r) when not (register_overlap dest i.arg) ->
|
||||
` xorl {emit_reg dest}, {emit_reg dest}\n`;
|
||||
` movw {emit_addressing addr i.arg 0}, {emit_reg16 dest}\n`
|
||||
| (Sixteen_unsigned, _) ->
|
||||
` movzwl {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
| (Sixteen_signed, _) ->
|
||||
` movswl {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
end
|
||||
| Float ->
|
||||
` fldl {emit_addressing addr i.arg 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 ->
|
||||
if i.arg.(0) = tos then
|
||||
` fstpl {emit_addressing addr i.arg 1}\n`
|
||||
else begin
|
||||
` fldl {emit_reg i.arg.(0)}\n`;
|
||||
` fstpl {emit_addressing addr i.arg 1}\n`
|
||||
end
|
||||
end
|
||||
| Lop(Istore(chunk, addr)) ->
|
||||
(* i.arg.(0) is guaranteed to be in %edx, actually *)
|
||||
begin match chunk with
|
||||
Word -> fatal_error "Emit_i386: store word"
|
||||
| Byte_unsigned | Byte_signed ->
|
||||
` movb {emit_reg8 i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
|
||||
| Sixteen_unsigned | Sixteen_signed ->
|
||||
` movw {emit_reg16 i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
|
||||
end
|
||||
| Lop(Ialloc n) ->
|
||||
if !fastcode_flag then begin
|
||||
let lbl_redo = new_label() in
|
||||
`{emit_label lbl_redo}: movl {emit_symbol "young_ptr"}, %eax\n`;
|
||||
` subl ${emit_int n}, %eax\n`;
|
||||
` movl %eax, {emit_symbol "young_ptr"}\n`;
|
||||
` cmpl {emit_symbol "young_limit"}, %eax\n`;
|
||||
let lbl_call_gc = new_label() in
|
||||
let lbl_frame = record_frame_label i.live in
|
||||
` jb {emit_label lbl_call_gc}\n`;
|
||||
` leal 4(%eax), {emit_reg i.res.(0)}\n`;
|
||||
call_gc_sites :=
|
||||
{ gc_lbl = lbl_call_gc;
|
||||
gc_return_lbl = lbl_redo;
|
||||
gc_frame = lbl_frame } :: !call_gc_sites
|
||||
end else begin
|
||||
begin match n with
|
||||
8 -> ` call {emit_symbol "caml_alloc1"}\n`
|
||||
| 12 -> ` call {emit_symbol "caml_alloc2"}\n`
|
||||
| 16 -> ` call {emit_symbol "caml_alloc3"}\n`
|
||||
| _ -> ` movl ${emit_int n}, %eax\n`;
|
||||
` call {emit_symbol "caml_alloc"}\n`
|
||||
end;
|
||||
`{record_frame i.live} leal 4(%eax), {emit_reg i.res.(0)}\n`
|
||||
end
|
||||
| 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 Icheckbound) ->
|
||||
if !range_check_trap = 0 then range_check_trap := new_label();
|
||||
` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
|
||||
` jbe {emit_label !range_check_trap}\n`
|
||||
| Lop(Iintop_imm(Icheckbound, n)) ->
|
||||
if !range_check_trap = 0 then range_check_trap := new_label();
|
||||
` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`;
|
||||
` jbe {emit_label !range_check_trap}\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(Idiv, n)) ->
|
||||
let l = Misc.log2 n in
|
||||
let lbl = new_label() in
|
||||
output_test_zero i.arg.(0);
|
||||
` jge {emit_label lbl}\n`;
|
||||
` addl ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`;
|
||||
`{emit_label lbl}: sarl ${emit_int l}, {emit_reg i.arg.(0)}\n`
|
||||
| Lop(Iintop_imm(Imod, n)) ->
|
||||
let l = Misc.log2 n in
|
||||
let lbl = new_label() in
|
||||
` movl {emit_reg i.arg.(0)}, %eax\n`;
|
||||
` testl %eax, %eax\n`;
|
||||
` jge {emit_label lbl}\n`;
|
||||
` addl ${emit_int(n-1)}, %eax\n`;
|
||||
`{emit_label lbl}: andl ${emit_int(-n)}, %eax\n`;
|
||||
` subl %eax, {emit_reg i.arg.(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(Inegf | Iabsf as floatop) ->
|
||||
if i.arg.(0) <> tos then
|
||||
` fldl {emit_reg i.arg.(0)}\n`;
|
||||
` {emit_string(instr_for_floatop floatop)}\n`
|
||||
| Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev)
|
||||
as floatop) ->
|
||||
if i.arg.(0) = tos && i.arg.(1) = tos then
|
||||
(* both operands on top of FP stack *)
|
||||
` {emit_string(instr_for_floatop_pop floatop)} %st, %st(1)\n`
|
||||
else if i.arg.(0) = tos then
|
||||
(* first operand on stack *)
|
||||
` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n`
|
||||
else if i.arg.(1) = tos then
|
||||
(* second operand on stack *)
|
||||
` {emit_string(instr_for_floatop_reversed floatop)} {emit_reg i.arg.(0)}\n`
|
||||
else begin
|
||||
(* both operands in memory *)
|
||||
` fldl {emit_reg i.arg.(0)}\n`;
|
||||
` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n`
|
||||
end
|
||||
| Lop(Ifloatofint) ->
|
||||
begin match i.arg.(0).loc with
|
||||
Stack s ->
|
||||
` fildl {emit_reg i.arg.(0)}\n`
|
||||
| _ ->
|
||||
` pushl {emit_reg i.arg.(0)}\n`;
|
||||
` fildl (%esp)\n`;
|
||||
` addl $4, %esp\n`
|
||||
end
|
||||
| Lop(Iintoffloat) ->
|
||||
if i.arg.(0) <> tos then
|
||||
` fldl {emit_reg i.arg.(0)}\n`;
|
||||
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`;
|
||||
begin match i.res.(0).loc with
|
||||
Stack s ->
|
||||
` fistpl {emit_reg i.res.(0)}\n`
|
||||
| _ ->
|
||||
` fistpl (%esp)\n`;
|
||||
` movl (%esp), {emit_reg i.res.(0)}\n`
|
||||
end;
|
||||
` fldcw 4(%esp)\n`;
|
||||
` addl $8, %esp\n`;
|
||||
stack_offset := !stack_offset + 8
|
||||
| Lop(Ispecific(Ilea addr)) ->
|
||||
` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Ispecific(Istore_int(n, addr))) ->
|
||||
` movl ${emit_int n}, {emit_addressing addr i.arg 0}\n`
|
||||
| Lop(Ispecific(Istore_symbol(s, addr))) ->
|
||||
` movl ${emit_symbol s}, {emit_addressing addr i.arg 0}\n`
|
||||
| Lop(Ispecific(Ioffset_loc(n, addr))) ->
|
||||
` addl ${emit_int n}, {emit_addressing addr i.arg 0}\n`
|
||||
| Lop(Ispecific(Ipush)) ->
|
||||
(* Push arguments in reverse order *)
|
||||
for n = Array.length i.arg - 1 downto 0 do
|
||||
let r = i.arg.(n) in
|
||||
match r with
|
||||
{loc = Reg _; typ = Float} ->
|
||||
` subl $8, %esp\n`;
|
||||
` fstpl 0(%esp)\n`;
|
||||
stack_offset := !stack_offset + 8
|
||||
| {loc = Stack sl; typ = Float} ->
|
||||
let ofs = slot_offset sl 1 in
|
||||
` pushl {emit_int(ofs + 4)}(%esp)\n`;
|
||||
` pushl {emit_int(ofs + 4)}(%esp)\n`;
|
||||
stack_offset := !stack_offset + 8
|
||||
| _ ->
|
||||
` pushl {emit_reg r}\n`;
|
||||
stack_offset := !stack_offset + 4
|
||||
done
|
||||
| Lop(Ispecific(Ipush_int n)) ->
|
||||
` pushl ${emit_int n}\n`;
|
||||
stack_offset := !stack_offset + 4
|
||||
| Lop(Ispecific(Ipush_symbol s)) ->
|
||||
` pushl ${emit_symbol s}\n`;
|
||||
stack_offset := !stack_offset + 4
|
||||
| Lop(Ispecific(Ipush_load addr)) ->
|
||||
` pushl {emit_addressing addr i.arg 0}\n`;
|
||||
stack_offset := !stack_offset + 4
|
||||
| Lop(Ispecific(Ipush_load_float addr)) ->
|
||||
` pushl {emit_addressing (offset_addressing addr 4) i.arg 0}\n`;
|
||||
` pushl {emit_addressing addr i.arg 0}\n`;
|
||||
stack_offset := !stack_offset + 8
|
||||
| Lop(Ispecific(Ifloatarithmem(op, addr))) ->
|
||||
if i.arg.(0) <> tos then
|
||||
` fldl {emit_reg i.arg.(0)}\n`;
|
||||
` {emit_string(instr_for_floatarithmem op)} {emit_addressing addr i.arg 1}\n`
|
||||
| Lreloadretaddr ->
|
||||
()
|
||||
| Lreturn ->
|
||||
output_epilogue();
|
||||
` ret\n`
|
||||
| Llabel lbl ->
|
||||
`{emit_label lbl}:\n`
|
||||
| Lbranch lbl ->
|
||||
` jmp {emit_label lbl}\n`
|
||||
| Lcondbranch(tst, lbl) ->
|
||||
begin match tst with
|
||||
Itruetest ->
|
||||
output_test_zero i.arg.(0);
|
||||
` jne {emit_label lbl}\n`
|
||||
| Ifalsetest ->
|
||||
output_test_zero i.arg.(0);
|
||||
` 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((Isigned Ceq | Isigned Cne |
|
||||
Iunsigned Ceq | Iunsigned Cne) as cmp, 0) ->
|
||||
output_test_zero i.arg.(0);
|
||||
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((Ceq | Cne as cmp), neg) ->
|
||||
if i.arg.(1) <> tos then
|
||||
` fldl {emit_reg i.arg.(1)}\n`;
|
||||
if i.arg.(0) <> tos then
|
||||
` fldl {emit_reg i.arg.(0)}\n`;
|
||||
` fucompp\n`;
|
||||
` fnstsw %ax\n`;
|
||||
let neg1 = if cmp = Ceq then neg else not neg in
|
||||
if neg1 then begin (* branch if different *)
|
||||
` andb $68, %ah\n`;
|
||||
` xorb $64, %ah\n`;
|
||||
` jne {emit_label lbl}\n`
|
||||
end else begin (* branch if equal *)
|
||||
` andb $69, %ah\n`;
|
||||
` cmpb $64, %ah\n`;
|
||||
` je {emit_label lbl}\n`
|
||||
end
|
||||
| Ifloattest(cmp, neg) ->
|
||||
let actual_cmp =
|
||||
if i.arg.(0) = tos && i.arg.(1) = tos then begin
|
||||
(* both args on top of FP stack *)
|
||||
` fcompp\n`;
|
||||
cmp
|
||||
end else if i.arg.(0) = tos then begin
|
||||
(* first arg on top of FP stack *)
|
||||
` fcompl {emit_reg i.arg.(1)}\n`;
|
||||
cmp
|
||||
end else if i.arg.(1) = tos then begin
|
||||
(* second arg on top of FP stack *)
|
||||
` fcompl {emit_reg i.arg.(0)}\n`;
|
||||
Cmm.swap_comparison cmp
|
||||
end else begin
|
||||
` fldl {emit_reg i.arg.(0)}\n`;
|
||||
` fcompl {emit_reg i.arg.(1)}\n`;
|
||||
cmp
|
||||
end in
|
||||
` fnstsw %ax\n`;
|
||||
begin match actual_cmp with
|
||||
Cle ->
|
||||
` andb $69, %ah\n`;
|
||||
` decb %ah\n`;
|
||||
` cmpb $64, %ah\n`;
|
||||
if neg
|
||||
then ` jae `
|
||||
else ` jb `
|
||||
| Cge ->
|
||||
` andb $5, %ah\n`;
|
||||
if neg
|
||||
then ` jne `
|
||||
else ` je `
|
||||
| Clt ->
|
||||
` andb $69, %ah\n`;
|
||||
` cmpb $1, %ah\n`;
|
||||
if neg
|
||||
then ` jne `
|
||||
else ` je `
|
||||
| Cgt ->
|
||||
` andb $69, %ah\n`;
|
||||
if neg
|
||||
then ` jne `
|
||||
else ` je `
|
||||
| _ -> fatal_error "Emit_i386: floattest"
|
||||
end;
|
||||
`{emit_label lbl}\n`
|
||||
| Ioddtest ->
|
||||
` testl $1, {emit_reg i.arg.(0)}\n`;
|
||||
` jne {emit_label lbl}\n`
|
||||
| Ieventest ->
|
||||
` testl $1, {emit_reg i.arg.(0)}\n`;
|
||||
` je {emit_label lbl}\n`
|
||||
end
|
||||
| Lcondbranch3(lbl0, lbl1, lbl2) ->
|
||||
` cmpl $1, {emit_reg i.arg.(0)}\n`;
|
||||
begin match lbl0 with
|
||||
None -> ()
|
||||
| Some lbl -> ` jb {emit_label lbl}\n`
|
||||
end;
|
||||
begin match lbl1 with
|
||||
None -> ()
|
||||
| Some lbl -> ` je {emit_label lbl}\n`
|
||||
end;
|
||||
begin match lbl2 with
|
||||
None -> ()
|
||||
| Some lbl -> ` jg {emit_label lbl}\n`
|
||||
end
|
||||
| Lswitch jumptbl ->
|
||||
let lbl = new_label() in
|
||||
` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 4)\n`;
|
||||
` .data\n`;
|
||||
`{emit_label lbl}:`;
|
||||
for i = 0 to Array.length jumptbl - 1 do
|
||||
` .long {emit_label jumptbl.(i)}\n`
|
||||
done;
|
||||
` .text\n`
|
||||
| Lsetuptrap lbl ->
|
||||
` call {emit_label lbl}\n`
|
||||
| Lpushtrap ->
|
||||
` pushl {emit_symbol "caml_exception_pointer"}\n`;
|
||||
` movl %esp, {emit_symbol "caml_exception_pointer"}\n`;
|
||||
stack_offset := !stack_offset + 8
|
||||
| Lpoptrap ->
|
||||
` popl {emit_symbol "caml_exception_pointer"}\n`;
|
||||
` addl $4, %esp\n`;
|
||||
stack_offset := !stack_offset - 8
|
||||
| Lraise ->
|
||||
` movl {emit_symbol "caml_exception_pointer"}, %esp\n`;
|
||||
` popl {emit_symbol "caml_exception_pointer"}\n`;
|
||||
` ret\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;
|
||||
fastcode_flag := fundecl.fun_fast;
|
||||
tailrec_entry_point := new_label();
|
||||
stack_offset := 0;
|
||||
float_constants := [];
|
||||
call_gc_sites := [];
|
||||
range_check_trap := 0;
|
||||
` .text\n`;
|
||||
emit_align 4;
|
||||
` .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}:\n`;
|
||||
emit_all fundecl.fun_body;
|
||||
List.iter emit_call_gc !call_gc_sites;
|
||||
if !range_check_trap > 0 then
|
||||
`{emit_label !range_check_trap}: call {emit_symbol "array_bound_error"}\n`;
|
||||
(* Never returns, but useful to have retaddr on stack for debugging *)
|
||||
List.iter emit_float_constant !float_constants
|
||||
|
||||
(* Emission of data *)
|
||||
|
||||
let emit_item = function
|
||||
Cdefine_symbol s ->
|
||||
` .globl {emit_symbol s}\n`;
|
||||
`{emit_symbol s}:\n`
|
||||
| Cdefine_label lbl ->
|
||||
`{emit_label (10000 + lbl)}:\n`
|
||||
| Cint8 n ->
|
||||
` .byte {emit_int n}\n`
|
||||
| Cint16 n ->
|
||||
` {emit_string word_dir} {emit_int n}\n`
|
||||
| Cint n ->
|
||||
` .long {emit_nativeint n}\n`
|
||||
| Cfloat f ->
|
||||
` .double {emit_string f}\n`
|
||||
| Csymbol_address s ->
|
||||
` .long {emit_symbol s}\n`
|
||||
| Clabel_address lbl ->
|
||||
` .long {emit_label (10000 + lbl)}\n`
|
||||
| Cstring s ->
|
||||
if use_ascii_dir
|
||||
then emit_string_directive " .ascii " s
|
||||
else emit_bytes_directive " .byte " s
|
||||
| Cskip n ->
|
||||
if n > 0 then ` {emit_string skip_dir} {emit_int n}\n`
|
||||
| Calign n ->
|
||||
emit_align n
|
||||
|
||||
let data l =
|
||||
` .data\n`;
|
||||
List.iter emit_item l
|
||||
|
||||
(* Beginning / end of an assembly file *)
|
||||
|
||||
let begin_assembly() =
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
|
||||
` .data\n`;
|
||||
` .globl {emit_symbol lbl_begin}\n`;
|
||||
`{emit_symbol lbl_begin}:\n`;
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
|
||||
` .text\n`;
|
||||
` .globl {emit_symbol lbl_begin}\n`;
|
||||
`{emit_symbol lbl_begin}:\n`
|
||||
|
||||
let end_assembly() =
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
|
||||
` .text\n`;
|
||||
` .globl {emit_symbol lbl_end}\n`;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
` .data\n`;
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
|
||||
` .globl {emit_symbol lbl_end}\n`;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
` .long 0\n`;
|
||||
let lbl = Compilenv.current_unit_name() ^ "_frametable" in
|
||||
` .globl {emit_symbol lbl}\n`;
|
||||
`{emit_symbol lbl}:\n`;
|
||||
` .long {emit_int (List.length !frame_descriptors)}\n`;
|
||||
List.iter emit_frame !frame_descriptors;
|
||||
frame_descriptors := []
|
||||
|
|
@ -1,730 +0,0 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Emission of Motorola 68020 assembly code (MIT syntax) *)
|
||||
|
||||
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
|
||||
|
||||
let stack_offset = ref 0
|
||||
|
||||
(* Layout of the stack frame *)
|
||||
|
||||
let frame_size () = (* includes return address *)
|
||||
!stack_offset +
|
||||
4 * (num_stack_slots.(0) + num_stack_slots.(1)) +
|
||||
8 * num_stack_slots.(2) +
|
||||
4 (* return address *)
|
||||
|
||||
let slot_offset loc cl =
|
||||
match loc with
|
||||
Incoming n -> frame_size() + n
|
||||
| Local n ->
|
||||
if cl = 0
|
||||
then !stack_offset + n * 4
|
||||
else if cl = 1
|
||||
then !stack_offset + num_stack_slots.(0) * 4 + n * 4
|
||||
else !stack_offset +
|
||||
(num_stack_slots.(0) + num_stack_slots.(1)) * 4 + n * 8
|
||||
| Outgoing n -> n
|
||||
|
||||
(* Output a symbol *)
|
||||
|
||||
let emit_symbol s =
|
||||
emit_char '_'; Emitaux.emit_symbol '$' s
|
||||
|
||||
(* Output a label *)
|
||||
|
||||
let emit_label lbl =
|
||||
emit_char 'L'; emit_int lbl
|
||||
|
||||
(* Output an align directive *)
|
||||
|
||||
let emit_align n =
|
||||
` .align {emit_int n}\n`
|
||||
|
||||
(* Output a pseudo-register *)
|
||||
|
||||
let emit_reg = function
|
||||
{ loc = Reg r } ->
|
||||
emit_string (register_name r)
|
||||
| { loc = Stack s } as r ->
|
||||
let ofs = slot_offset s (register_class r) in
|
||||
if ofs = 0
|
||||
then `a7@`
|
||||
else `a7@({emit_int ofs})`
|
||||
| { loc = Unknown } ->
|
||||
fatal_error "Emit_m68k.emit_reg"
|
||||
|
||||
(* Check if the given register is an address register *)
|
||||
|
||||
let is_address_reg = function { loc = Reg _; typ = Addr } -> true | _ -> false
|
||||
|
||||
(* Check if the given register overlaps (same location) with the given
|
||||
array of registers *)
|
||||
|
||||
let register_overlap reg arr =
|
||||
try
|
||||
for i = 0 to Array.length arr - 1 do
|
||||
if reg.loc = arr.(i).loc then raise Exit
|
||||
done;
|
||||
false
|
||||
with Exit ->
|
||||
true
|
||||
|
||||
(* Output a suffix for a floating-point instruction -- either .x if
|
||||
the argument is a register or .d if it's in memory. *)
|
||||
|
||||
let emit_float_size r =
|
||||
match r.loc with
|
||||
Reg _ -> `x`
|
||||
| _ -> `d`
|
||||
|
||||
let emit_float_size2 r1 r2 =
|
||||
match (r1.loc, r2.loc) with
|
||||
(Reg _, Reg _) -> `x`
|
||||
| _ -> `d`
|
||||
|
||||
(* Output an addressing mode *)
|
||||
|
||||
let emit_displacement d =
|
||||
if d <> 0 then `{emit_int d}, `
|
||||
|
||||
let emit_addressing addr r n =
|
||||
match addr with
|
||||
Ibased(s, d) ->
|
||||
`{emit_symbol s}`;
|
||||
if d <> 0 then ` + {emit_int d}`
|
||||
| Iindexed d ->
|
||||
`{emit_reg r.(n)}@`;
|
||||
if d <> 0 then `({emit_int d})`
|
||||
| Iindexed2 d ->
|
||||
`{emit_reg r.(n)}@({emit_int d}, {emit_reg r.(n+1)}:l)`
|
||||
| Iscaled(scale, d) ->
|
||||
`@({emit_int d}, {emit_reg r.(n)}:l:{emit_int scale})`
|
||||
| Iindexed2scaled(scale, d) ->
|
||||
`{emit_reg r.(n)}@({emit_int d}, {emit_reg r.(n+1)}:l:{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_label live =
|
||||
let lbl = new_label() in
|
||||
let live_offset = ref [] in
|
||||
Reg.Set.iter
|
||||
(function
|
||||
{typ = Addr; loc = Reg r} ->
|
||||
live_offset := ((r lsl 1) + 1) :: !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}:\n`
|
||||
|
||||
let emit_frame fd =
|
||||
` .long {emit_label fd.fd_lbl}\n`;
|
||||
` .word {emit_int fd.fd_frame_size}\n`;
|
||||
` .word {emit_int (List.length fd.fd_live_offset)}\n`;
|
||||
List.iter
|
||||
(fun n ->
|
||||
` .word {emit_int n}\n`)
|
||||
fd.fd_live_offset;
|
||||
emit_align 4
|
||||
|
||||
(* Names for instructions *)
|
||||
|
||||
let instr_for_intop = function
|
||||
Iadd -> "addl"
|
||||
| Isub -> "subl"
|
||||
| Imul -> "mulsl"
|
||||
| Idiv -> "divsl"
|
||||
| Iand -> "andl"
|
||||
| Ior -> "orl"
|
||||
| Ixor -> "eorl"
|
||||
| Ilsl -> "lsll"
|
||||
| Ilsr -> "lsrl"
|
||||
| Iasr -> "asrl"
|
||||
| _ -> fatal_error "Emit_m68k: instr_for_intop"
|
||||
|
||||
let instr_for_floatop = function
|
||||
Inegf -> "fneg"
|
||||
| Iabsf -> "fabs"
|
||||
| Iaddf -> "fadd"
|
||||
| Isubf -> "fsub"
|
||||
| Imulf -> "fmul"
|
||||
| Idivf -> "fdiv"
|
||||
| _ -> fatal_error "Emit_m68k: instr_for_floatop"
|
||||
|
||||
let name_for_cond_branch = function
|
||||
Isigned Ceq -> "eq" | Isigned Cne -> "ne"
|
||||
| Isigned Cle -> "le" | Isigned Cgt -> "gt"
|
||||
| Isigned Clt -> "lt" | Isigned Cge -> "ge"
|
||||
| Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne"
|
||||
| Iunsigned Cle -> "ls" | Iunsigned Cgt -> "hi"
|
||||
| Iunsigned Clt -> "cs" | Iunsigned Cge -> "cc"
|
||||
|
||||
let name_for_float_cond_branch cond neg =
|
||||
match cond with
|
||||
Ceq -> if neg then "ne" else "eq"
|
||||
| Cne -> if neg then "eq" else "ne"
|
||||
| Cle -> if neg then "ugt" else "ole"
|
||||
| Cgt -> if neg then "ule" else "ogt"
|
||||
| Clt -> if neg then "uge" else "olt"
|
||||
| Cge -> if neg then "ult" else "oge"
|
||||
|
||||
(* Emit an immediate move in the given data register *)
|
||||
|
||||
let emit_move_immediate n dreg =
|
||||
if n >= -128 && n < 128
|
||||
then ` moveq #{emit_int n}, {emit_string dreg}\n`
|
||||
else ` movel #{emit_int n}, {emit_string dreg}\n`
|
||||
|
||||
(* Offset the stack by the given amount of bytes *)
|
||||
|
||||
let output_stack_offset n =
|
||||
if n > 0 && n <= 8 then
|
||||
` subql #{emit_int(n)}, a7\n`
|
||||
else if n < 0 && n >= -8 then
|
||||
` addql #{emit_int(-n)}, a7\n`
|
||||
else
|
||||
` addw #{emit_int(-n)}, a7\n`
|
||||
|
||||
(* Deallocate the stack frame before a return or tail call *)
|
||||
|
||||
let output_epilogue () =
|
||||
let n = frame_size() - 4 in
|
||||
if n > 0 then output_stack_offset (-n)
|
||||
|
||||
(* Record the state of the condition codes *)
|
||||
|
||||
type condition_code = CCundefined | CCreflect of Reg.t
|
||||
|
||||
let cc_state = ref CCundefined
|
||||
|
||||
let undef_cc () =
|
||||
cc_state := CCundefined
|
||||
|
||||
let set_cc reg =
|
||||
cc_state := CCreflect reg
|
||||
|
||||
let output_test reg =
|
||||
match !cc_state with
|
||||
CCreflect r when r.loc = reg.loc -> ()
|
||||
| _ ->
|
||||
` tstl {emit_reg reg}\n`;
|
||||
cc_state := CCreflect reg
|
||||
|
||||
(* Output the assembly code for an instruction *)
|
||||
|
||||
(* Name of current function *)
|
||||
let function_name = ref ""
|
||||
(* Entry point for tail recursive calls *)
|
||||
let tailrec_entry_point = ref 0
|
||||
(* Label of trap for out-of-range accesses *)
|
||||
let range_check_trap = ref 0
|
||||
|
||||
let emit_instr i =
|
||||
match i.desc with
|
||||
Lend -> ()
|
||||
| Lop(Imove | Ispill | Ireload) ->
|
||||
let src = i.arg.(0) and dst = i.res.(0) in
|
||||
if src.loc <> dst.loc then begin
|
||||
match (src, dst) with
|
||||
({typ = Float; loc = Stack ss}, {loc = Stack sd}) ->
|
||||
let os = slot_offset ss 2 in
|
||||
let od = slot_offset sd 2 in
|
||||
` movel ({emit_int os}, a7), ({emit_int od}, a7)\n`;
|
||||
` movel ({emit_int (os+4)}, a7), ({emit_int (od+4)}, a7)\n`;
|
||||
undef_cc()
|
||||
| ({typ = Float}, _) ->
|
||||
` fmove{emit_float_size2 src dst} {emit_reg src}, {emit_reg dst}\n`
|
||||
| (_, _) ->
|
||||
` movel {emit_reg src}, {emit_reg dst}\n`;
|
||||
set_cc dst
|
||||
end
|
||||
| Lop(Iconst_int n) ->
|
||||
begin match i.res.(0) with
|
||||
{typ = Addr; loc = Reg _} ->
|
||||
if Nativeint.cmp n (-32768) >= 0 && Nativeint.cmp n 32768 < 0 then
|
||||
` movew #{emit_nativeint n}, {emit_reg i.res.(0)}\n`
|
||||
else
|
||||
` movel #{emit_nativeint n}, {emit_reg i.res.(0)}\n`
|
||||
| _ when Nativeint.sign n = 0 ->
|
||||
` clrl {emit_reg i.res.(0)}\n`;
|
||||
set_cc i.res.(0)
|
||||
| {typ = Int; loc = Reg _}
|
||||
when Nativeint.cmp n (-128) >= 0 && Nativeint.cmp n 128 < 0 ->
|
||||
` moveq #{emit_nativeint n}, {emit_reg i.res.(0)}\n`;
|
||||
set_cc i.res.(0)
|
||||
| _ ->
|
||||
` movel #{emit_nativeint n}, {emit_reg i.res.(0)}\n`;
|
||||
set_cc i.res.(0)
|
||||
end
|
||||
| Lop(Iconst_float s) ->
|
||||
let f = float_of_string s in
|
||||
if f = 0.0 then
|
||||
` fmovecr #0x0F, {emit_reg i.res.(0)}\n`
|
||||
else if f = 1.0 then
|
||||
` fmovecr #0x32, {emit_reg i.res.(0)}\n`
|
||||
else
|
||||
` fmoved #0r{emit_string s}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Iconst_symbol s) ->
|
||||
` lea {emit_symbol s}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Icall_ind) ->
|
||||
` jbsr {emit_reg i.arg.(0)}@\n`;
|
||||
record_frame i.live;
|
||||
undef_cc()
|
||||
| Lop(Icall_imm s) ->
|
||||
` jbsr {emit_symbol s}\n`;
|
||||
record_frame i.live;
|
||||
undef_cc()
|
||||
| Lop(Itailcall_ind) ->
|
||||
output_epilogue();
|
||||
` jmp {emit_reg i.arg.(0)}@\n`;
|
||||
undef_cc()
|
||||
| Lop(Itailcall_imm s) ->
|
||||
if s = !function_name then
|
||||
` bra {emit_label !tailrec_entry_point}\n`
|
||||
else begin
|
||||
output_epilogue();
|
||||
` jmp {emit_symbol s}\n`
|
||||
end;
|
||||
undef_cc()
|
||||
| Lop(Iextcall(s, alloc)) ->
|
||||
if alloc then begin
|
||||
` lea {emit_symbol s}, a0\n`;
|
||||
` jbsr {emit_symbol "caml_c_call"}\n`;
|
||||
record_frame i.live
|
||||
end else begin
|
||||
` jbsr {emit_symbol s}\n`
|
||||
end;
|
||||
if Array.length i.res > 0 && i.res.(0).typ = Float then begin
|
||||
` movel d1, a7@-\n`;
|
||||
` movel d0, a7@-\n`;
|
||||
` fmoved a7@+, {emit_reg i.res.(0)}\n`
|
||||
end;
|
||||
undef_cc()
|
||||
| Lop(Istackoffset n) ->
|
||||
output_stack_offset n;
|
||||
stack_offset := !stack_offset + n;
|
||||
undef_cc()
|
||||
| Lop(Iload(chunk, addr)) ->
|
||||
let dest = i.res.(0) in
|
||||
begin match dest.typ with
|
||||
Int | Addr ->
|
||||
begin match chunk with
|
||||
Word ->
|
||||
` movel {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
| Byte_unsigned when not (register_overlap dest i.arg) ->
|
||||
` clrl {emit_reg dest}\n`;
|
||||
` moveb {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
| Byte_unsigned ->
|
||||
` moveb {emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
|
||||
` andl #0xFF, {emit_reg dest}\n`
|
||||
| Byte_signed ->
|
||||
` moveb {emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
|
||||
` extbl {emit_reg dest}\n`
|
||||
| Sixteen_unsigned when not (register_overlap dest i.arg) ->
|
||||
` clrl {emit_reg dest}\n`;
|
||||
` movew {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
| Sixteen_unsigned ->
|
||||
` movew {emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
|
||||
` andl #0xFFFF, {emit_reg dest}\n`
|
||||
| Sixteen_signed ->
|
||||
` movew {emit_addressing addr i.arg 0}, {emit_reg dest}\n`;
|
||||
` extl {emit_reg dest}\n`
|
||||
end;
|
||||
set_cc dest
|
||||
| Float ->
|
||||
` fmoved {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
end
|
||||
| Lop(Istore(chunk, addr)) ->
|
||||
let src = i.arg.(0) in
|
||||
let instr =
|
||||
match src.typ with
|
||||
Int ->
|
||||
begin match chunk with
|
||||
Word -> "movel"
|
||||
| Byte_unsigned | Byte_signed -> "moveb"
|
||||
| Sixteen_unsigned | Sixteen_signed -> "movew"
|
||||
end
|
||||
| Addr -> "movel"
|
||||
| Float -> "fmoved" in
|
||||
` {emit_string instr} {emit_reg src}, {emit_addressing addr i.arg 1}\n`;
|
||||
undef_cc()
|
||||
| Lop(Ialloc n) ->
|
||||
if !fastcode_flag then begin
|
||||
let lbl_frame = record_frame_label i.live in
|
||||
` subl #{emit_int n}, d6\n`;
|
||||
` cmpl {emit_symbol "young_limit"}, d6\n`;
|
||||
` bcc {emit_label lbl_frame}\n`;
|
||||
emit_move_immediate n "d5";
|
||||
` jbsr {emit_symbol "caml_call_gc"}\n`;
|
||||
`{emit_label lbl_frame}: movel d6, {emit_reg i.res.(0)}\n`;
|
||||
` addql #4, {emit_reg i.res.(0)}\n`
|
||||
end else begin
|
||||
begin match n with
|
||||
8 -> ` jbsr {emit_symbol "caml_alloc1"}\n`
|
||||
| 12 -> ` jbsr {emit_symbol "caml_alloc2"}\n`
|
||||
| 16 -> ` jbsr {emit_symbol "caml_alloc3"}\n`
|
||||
| _ -> emit_move_immediate n "d5";
|
||||
` jbsr {emit_symbol "caml_alloc"}\n`
|
||||
end;
|
||||
`{record_frame i.live} movel d6, {emit_reg i.res.(0)}\n`;
|
||||
` addql #4, {emit_reg i.res.(0)}\n`
|
||||
end;
|
||||
undef_cc()
|
||||
| Lop(Iintop(Icomp cmp)) ->
|
||||
` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
|
||||
let b = name_for_cond_branch cmp in
|
||||
` s{emit_string b} {emit_reg i.res.(0)}\n`;
|
||||
` negb {emit_reg i.res.(0)}\n`;
|
||||
` extbl {emit_reg i.res.(0)}\n`;
|
||||
set_cc i.res.(0)
|
||||
| Lop(Iintop_imm(Icomp cmp, n)) ->
|
||||
` cmpl #{emit_int n}, {emit_reg i.arg.(0)}\n`;
|
||||
let b = name_for_cond_branch cmp in
|
||||
` s{emit_string b} {emit_reg i.res.(0)}\n`;
|
||||
` negb {emit_reg i.res.(0)}\n`;
|
||||
` extbl {emit_reg i.res.(0)}\n`;
|
||||
set_cc i.res.(0)
|
||||
| Lop(Iintop Icheckbound) ->
|
||||
if !range_check_trap = 0 then range_check_trap := new_label();
|
||||
` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
|
||||
` bls {emit_label !range_check_trap}\n`
|
||||
| Lop(Iintop_imm(Icheckbound, n)) ->
|
||||
if !range_check_trap = 0 then range_check_trap := new_label();
|
||||
` cmpl #{emit_int n}, {emit_reg i.arg.(0)}\n`;
|
||||
` bls {emit_label !range_check_trap}\n`
|
||||
| Lop(Iintop_imm(Iadd, n)) ->
|
||||
let dest = i.res.(0) in
|
||||
begin match dest with
|
||||
{loc = Reg _} when n > 0 && n <= 8 ->
|
||||
` addql #{emit_int n}, {emit_reg dest}\n`;
|
||||
set_cc i.res.(0)
|
||||
| {loc = Reg _} when n < 0 && n >= -8 ->
|
||||
` subql #{emit_int(-n)}, {emit_reg dest}\n`;
|
||||
set_cc i.res.(0)
|
||||
| _ ->
|
||||
` addl #{emit_int n}, {emit_reg dest}\n`;
|
||||
set_cc i.res.(0)
|
||||
end
|
||||
| Lop(Iintop_imm(Isub, n)) ->
|
||||
let dest = i.res.(0) in
|
||||
begin match dest with
|
||||
{loc = Reg _} when n > 0 && n <= 8 ->
|
||||
` subql #{emit_int n}, {emit_reg dest}\n`;
|
||||
set_cc i.res.(0)
|
||||
| {loc = Reg _} when n < 0 && n >= -8 ->
|
||||
` addql #{emit_int(-n)}, {emit_reg dest}\n`;
|
||||
set_cc i.res.(0)
|
||||
| _ ->
|
||||
` subl #{emit_int n}, {emit_reg dest}\n`;
|
||||
set_cc i.res.(0)
|
||||
end
|
||||
| Lop(Iintop_imm(Idiv, n)) when n = 1 lsl (Misc.log2 n) ->
|
||||
let l = Misc.log2 n in
|
||||
let lbl = new_label() in
|
||||
output_test i.arg.(0);
|
||||
` bge {emit_label lbl}\n`;
|
||||
` addl #{emit_int(n-1)}, {emit_reg i.arg.(0)}\n`;
|
||||
`{emit_label lbl}:`;
|
||||
if l <= 8 then
|
||||
` asrl #{emit_int l}, {emit_reg i.arg.(0)}\n`
|
||||
else begin
|
||||
` moveq #{emit_int l}, d5\n`;
|
||||
` asrl d0, {emit_reg i.arg.(0)}\n`
|
||||
end;
|
||||
set_cc i.res.(0)
|
||||
| Lop(Iintop Imod) ->
|
||||
` movel {emit_reg i.arg.(0)}, d5\n`;
|
||||
` divsll {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}:d5\n`;
|
||||
undef_cc()
|
||||
| Lop(Iintop_imm(Imod, n)) when n = 1 lsl (Misc.log2 n) ->
|
||||
let l = Misc.log2 n in
|
||||
let lbl = new_label() in
|
||||
` movel {emit_reg i.arg.(0)}, d5\n`;
|
||||
` bge {emit_label lbl}\n`;
|
||||
` addl #{emit_int(n-1)}, d5\n`;
|
||||
`{emit_label lbl}: andl #{emit_int(-n)}, d5\n`;
|
||||
` subl d5, {emit_reg i.arg.(0)}\n`;
|
||||
set_cc i.res.(0)
|
||||
| Lop(Iintop_imm(Imod, n)) ->
|
||||
` movel {emit_reg i.arg.(0)}, d5\n`;
|
||||
` divsll #{emit_int n}, {emit_reg i.res.(0)}:d5\n`;
|
||||
undef_cc()
|
||||
| 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`;
|
||||
set_cc i.res.(0)
|
||||
| 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`;
|
||||
set_cc i.res.(0)
|
||||
| Lop(Inegf | Iabsf as floatop) ->
|
||||
` {emit_string(instr_for_floatop floatop)}{emit_float_size i.arg.(0)} {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Iaddf | Isubf | Imulf | Idivf as floatop) ->
|
||||
` {emit_string(instr_for_floatop floatop)}{emit_float_size i.arg.(1)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Ifloatofint) ->
|
||||
` fmovel {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Iintoffloat) ->
|
||||
` fintrz{emit_float_size i.arg.(0)} {emit_reg i.arg.(0)}, fp0\n`;
|
||||
` fmovel fp0, {emit_reg i.res.(0)}\n`;
|
||||
undef_cc()
|
||||
| Lop(Ispecific(Ilea addr)) ->
|
||||
` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Ispecific(Istore_int(n, addr))) ->
|
||||
if n = 0 then
|
||||
` clrl {emit_addressing addr i.arg 0}\n`
|
||||
else
|
||||
` movel #{emit_int n}, {emit_addressing addr i.arg 0}\n`;
|
||||
undef_cc()
|
||||
| Lop(Ispecific(Istore_symbol(s, addr))) ->
|
||||
` movel #{emit_symbol s}, {emit_addressing addr i.arg 0}\n`;
|
||||
undef_cc()
|
||||
| Lop(Ispecific(Ipush)) ->
|
||||
(* Push arguments in reverse order *)
|
||||
for n = Array.length i.arg - 1 downto 0 do
|
||||
let r = i.arg.(n) in
|
||||
match r with
|
||||
{loc = Reg _; typ = Float} ->
|
||||
` fmoved {emit_reg r}, a7@-\n`;
|
||||
stack_offset := !stack_offset + 8
|
||||
| {loc = Stack sl; typ = Float} ->
|
||||
let ofs = slot_offset sl 2 in
|
||||
` movel ({emit_int(ofs + 4)}, a7), a7@-\n`;
|
||||
` movel ({emit_int(ofs + 4)}, a7), a7@-\n`;
|
||||
stack_offset := !stack_offset + 8
|
||||
| _ ->
|
||||
` movel {emit_reg r}, a7@-\n`;
|
||||
stack_offset := !stack_offset + 4
|
||||
done;
|
||||
undef_cc()
|
||||
| Lop(Ispecific(Ipush_int n)) ->
|
||||
` movel #{emit_int n}, a7@-\n`;
|
||||
stack_offset := !stack_offset + 4;
|
||||
undef_cc()
|
||||
| Lop(Ispecific(Ipush_symbol s)) ->
|
||||
` pea {emit_symbol s}\n`;
|
||||
stack_offset := !stack_offset + 4;
|
||||
undef_cc()
|
||||
| Lop(Ispecific(Ipush_load addr)) ->
|
||||
` movel {emit_addressing addr i.arg 0}, a7@-\n`;
|
||||
stack_offset := !stack_offset + 4;
|
||||
undef_cc()
|
||||
| Lop(Ispecific(Ipush_load_float addr)) ->
|
||||
` movel {emit_addressing (offset_addressing addr 4) i.arg 0}, a7@-\n`;
|
||||
` movel {emit_addressing addr i.arg 0}, a7@-\n`;
|
||||
stack_offset := !stack_offset + 8;
|
||||
undef_cc()
|
||||
| Lreloadretaddr ->
|
||||
()
|
||||
| Lreturn ->
|
||||
output_epilogue();
|
||||
` rts\n`;
|
||||
undef_cc()
|
||||
| Llabel lbl ->
|
||||
`{emit_label lbl}:\n`;
|
||||
undef_cc()
|
||||
| Lbranch lbl ->
|
||||
` bra {emit_label lbl}\n`
|
||||
| Lcondbranch(tst, lbl) ->
|
||||
begin match tst with
|
||||
Itruetest ->
|
||||
output_test i.arg.(0);
|
||||
` bne {emit_label lbl}\n`
|
||||
| Ifalsetest ->
|
||||
output_test i.arg.(0);
|
||||
` beq {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
|
||||
` b{emit_string b} {emit_label lbl}\n`
|
||||
| Iinttest_imm(cmp, 0) ->
|
||||
output_test i.arg.(0);
|
||||
let b = name_for_cond_branch cmp in
|
||||
` b{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
|
||||
` b{emit_string b} {emit_label lbl}\n`
|
||||
| Ifloattest(cmp, neg) ->
|
||||
` fcmp{emit_float_size2 i.arg.(0) i.arg.(1)} {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
|
||||
let b = name_for_float_cond_branch cmp neg in
|
||||
` fb{emit_string b} {emit_label lbl}\n`
|
||||
| Ioddtest ->
|
||||
begin match i.arg.(0) with
|
||||
{typ = Addr; loc = Reg _} as arg ->
|
||||
` movel {emit_reg arg}, d5\n`;
|
||||
` btst #0, d5\n`
|
||||
| arg ->
|
||||
` btst #0, {emit_reg arg}\n`
|
||||
end;
|
||||
` bne {emit_label lbl}\n`
|
||||
| Ieventest ->
|
||||
begin match i.arg.(0) with
|
||||
{typ = Addr; loc = Reg _} as arg ->
|
||||
` movel {emit_reg arg}, d5\n`;
|
||||
` btst #0, d5\n`
|
||||
| arg ->
|
||||
` btst #0, {emit_reg arg}\n`
|
||||
end;
|
||||
` beq {emit_label lbl}\n`
|
||||
end;
|
||||
undef_cc()
|
||||
| Lcondbranch3(lbl0, lbl1, lbl2) ->
|
||||
` cmpl #1, {emit_reg i.arg.(0)}\n`;
|
||||
begin match lbl0 with
|
||||
None -> ()
|
||||
| Some lbl -> ` blt {emit_label lbl}\n`
|
||||
end;
|
||||
begin match lbl1 with
|
||||
None -> ()
|
||||
| Some lbl -> ` beq {emit_label lbl}\n`
|
||||
end;
|
||||
begin match lbl2 with
|
||||
None -> ()
|
||||
| Some lbl -> ` bgt {emit_label lbl}\n`
|
||||
end;
|
||||
undef_cc()
|
||||
| Lswitch jumptbl ->
|
||||
let lbl_load = new_label() in
|
||||
let lbl_table = new_label() in
|
||||
`{emit_label lbl_load}: movew pc@({emit_label lbl_table}-{emit_label lbl_load}-2:b, {emit_reg i.arg.(0)}:l:2), d0\n`;
|
||||
` jmp pc@(2, d0:w)\n`;
|
||||
`{emit_label lbl_table}:`;
|
||||
for i = 0 to Array.length jumptbl - 1 do
|
||||
` .word {emit_label jumptbl.(i)} - {emit_label lbl_table}\n`
|
||||
done;
|
||||
undef_cc()
|
||||
| Lsetuptrap lbl ->
|
||||
` bsr {emit_label lbl}\n`
|
||||
| Lpushtrap ->
|
||||
` movel d7, a7@-\n`;
|
||||
` movel a7, d7\n`;
|
||||
stack_offset := !stack_offset + 8;
|
||||
undef_cc()
|
||||
| Lpoptrap ->
|
||||
` movel a7@+, d7\n`;
|
||||
` addql #4, a7\n`;
|
||||
stack_offset := !stack_offset - 8;
|
||||
undef_cc()
|
||||
| Lraise ->
|
||||
` movel d7, a7\n`;
|
||||
` movel a7@+, d7\n`;
|
||||
` rts\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;
|
||||
fastcode_flag := fundecl.fun_fast;
|
||||
tailrec_entry_point := new_label();
|
||||
stack_offset := 0;
|
||||
range_check_trap := 0;
|
||||
undef_cc();
|
||||
` .text\n`;
|
||||
` .globl {emit_symbol fundecl.fun_name}\n`;
|
||||
`{emit_symbol fundecl.fun_name}:\n`;
|
||||
let n = frame_size() - 4 in
|
||||
if n > 0 then output_stack_offset n;
|
||||
`{emit_label !tailrec_entry_point}:\n`;
|
||||
emit_all fundecl.fun_body;
|
||||
if !range_check_trap > 0 then
|
||||
`{emit_label !range_check_trap}: jbsr {emit_symbol "array_bound_error"}\n`
|
||||
|
||||
(* Emission of data *)
|
||||
|
||||
let emit_item = function
|
||||
Cdefine_symbol s ->
|
||||
` .globl {emit_symbol s}\n`;
|
||||
`{emit_symbol s}:\n`
|
||||
| Cdefine_label lbl ->
|
||||
`{emit_label (10000 + lbl)}:\n`
|
||||
| Cint8 n ->
|
||||
` .byte {emit_int n}\n`
|
||||
| Cint16 n ->
|
||||
` .word {emit_int n}\n`
|
||||
| Cint n ->
|
||||
` .long {emit_nativeint n}\n`
|
||||
| Cfloat f ->
|
||||
` .double 0r{emit_string f}\n`
|
||||
| Csymbol_address s ->
|
||||
` .long {emit_symbol s}\n`
|
||||
| Clabel_address lbl ->
|
||||
` .long {emit_label (10000 + lbl)}\n`
|
||||
| Cstring s ->
|
||||
emit_string_directive " .ascii " s
|
||||
| Cskip n ->
|
||||
if n > 0 then ` .skip {emit_int n}\n`
|
||||
| Calign n ->
|
||||
emit_align n
|
||||
|
||||
let data l =
|
||||
` .data\n`;
|
||||
List.iter emit_item l
|
||||
|
||||
(* Beginning / end of an assembly file *)
|
||||
|
||||
let begin_assembly() =
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
|
||||
` .data\n`;
|
||||
` .globl {emit_symbol lbl_begin}\n`;
|
||||
`{emit_symbol lbl_begin}:\n`;
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
|
||||
` .text\n`;
|
||||
` .globl {emit_symbol lbl_begin}\n`;
|
||||
`{emit_symbol lbl_begin}:\n`
|
||||
|
||||
let end_assembly() =
|
||||
` .text\n`;
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
|
||||
` .globl {emit_symbol lbl_end}\n`;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
` .data\n`;
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
|
||||
` .globl {emit_symbol lbl_end}\n`;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
` .long 0\n`;
|
||||
let lbl = Compilenv.current_unit_name() ^ "_frametable" in
|
||||
` .globl {emit_symbol lbl}\n`;
|
||||
`{emit_symbol lbl}:\n`;
|
||||
` .long {emit_int (List.length !frame_descriptors)}\n`;
|
||||
List.iter emit_frame !frame_descriptors;
|
||||
frame_descriptors := []
|
||||
|
|
@ -1,634 +0,0 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Emission of Mips assembly code *)
|
||||
|
||||
open Misc
|
||||
open Cmm
|
||||
open Arch
|
||||
open Proc
|
||||
open Reg
|
||||
open Mach
|
||||
open Linearize
|
||||
open Emitaux
|
||||
|
||||
(* Determine whether we're emitting PIC code (IRIX -32 model)
|
||||
or absolute code *)
|
||||
|
||||
let pic =
|
||||
match Config.system with
|
||||
"ultrix" -> false
|
||||
| "irix" -> true
|
||||
| _ -> fatal_error "Emit_mips.pic"
|
||||
|
||||
(* 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 symbol *)
|
||||
|
||||
let emit_symbol s =
|
||||
Emitaux.emit_symbol '$' s
|
||||
|
||||
(* Output a pseudo-register *)
|
||||
|
||||
let emit_reg r =
|
||||
match r.loc with
|
||||
Reg r -> emit_string (register_name r)
|
||||
| _ -> fatal_error "Emit_mips.emit_reg"
|
||||
|
||||
(* Output the other half of a floating-point pseudo-register *)
|
||||
|
||||
let float_reg_twin_name = [|
|
||||
(* 100-104 *) "$f1"; "$f3"; "$f5"; "$f7"; "$f9";
|
||||
(* 105-108 *) "$f13"; "$f15"; "$f17"; "$f19";
|
||||
(* 109-114 *) "$f21"; "$f23"; "$f25"; "$f27"; "$f29"; "$f31"
|
||||
|]
|
||||
|
||||
let emit_twin_reg = function
|
||||
{ loc = Reg r; typ = Float } -> emit_string (float_reg_twin_name.(r - 100))
|
||||
| _ -> fatal_error "Emit_mips.emit_twin_reg"
|
||||
|
||||
let emit_lower_reg = if big_endian then emit_twin_reg else emit_reg
|
||||
let emit_upper_reg = if big_endian then emit_reg else emit_twin_reg
|
||||
|
||||
(* Record if $gp is needed (in PIC mode) *)
|
||||
|
||||
let uses_gp = ref false
|
||||
|
||||
(* Layout of the stack frame *)
|
||||
|
||||
let stack_offset = ref 0
|
||||
|
||||
let frame_size () =
|
||||
let size =
|
||||
!stack_offset +
|
||||
4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) +
|
||||
(if !contains_calls then if !uses_gp then 8 else 4 else 0) in
|
||||
Misc.align size 8
|
||||
|
||||
let slot_offset loc cl =
|
||||
match loc with
|
||||
Incoming n -> frame_size() + n
|
||||
| Local n ->
|
||||
if cl = 0
|
||||
then !stack_offset + num_stack_slots.(1) * 8 + n * 4
|
||||
else !stack_offset + n * 8
|
||||
| Outgoing n -> n
|
||||
|
||||
(* 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_mips.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}`
|
||||
|
||||
(* Communicate live registers at call points to the assembler *)
|
||||
|
||||
let int_reg_number = [|
|
||||
2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21
|
||||
|]
|
||||
|
||||
let float_reg_number = [|
|
||||
0; 2; 4; 6; 8; 12; 14; 16; 18; 20; 22; 24; 26; 28; 30
|
||||
|]
|
||||
|
||||
let liveregs instr extra_msk =
|
||||
(* The .livereg directive is not supported by old Ultrix versions of
|
||||
the MIPS assembler... *)
|
||||
if pic then begin
|
||||
(* $22, $23, $30 always live *)
|
||||
let int_mask = ref(0x00000302 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 (3 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
|
||||
end
|
||||
|
||||
let live_24 = 1 lsl (31 - 24)
|
||||
|
||||
(* 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 := ((int_reg_number.(r) lsl 1) + 1) :: !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 =
|
||||
` .word {emit_label fd.fd_lbl}\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 2\n`
|
||||
|
||||
(* In PIC mode, determine if $gp is used in the function *)
|
||||
|
||||
let rec instr_uses_gp i =
|
||||
match i.desc with
|
||||
Lend -> false
|
||||
| Lop(Iconst_symbol s) -> true
|
||||
| Lop(Icall_imm s) -> true
|
||||
| Lop(Itailcall_imm s) -> true
|
||||
| Lop(Iextcall(_, _)) -> true
|
||||
| Lop(Iload(_, Ibased(_, _))) -> true
|
||||
| Lop(Istore(_, Ibased(_, _))) -> true
|
||||
| Lop(Ialloc _) -> true
|
||||
| Lop(Iintop(Icheckbound)) -> true
|
||||
| Lop(Iintop_imm(Icheckbound, _)) -> true
|
||||
| Lswitch jumptbl -> true
|
||||
| _ -> instr_uses_gp i.next
|
||||
|
||||
(* Emit code to reload $gp after a jal *)
|
||||
|
||||
let reload_gp () =
|
||||
if !uses_gp then
|
||||
` lw $gp, {emit_int(frame_size() - 8)}($sp)\n`
|
||||
|
||||
(* Emit a branch to an external symbol. *)
|
||||
|
||||
let emit_branch_symbol s =
|
||||
if not pic then
|
||||
` j {emit_symbol s}\n`
|
||||
else begin
|
||||
` la $25, {emit_symbol s}\n`;
|
||||
` j $25\n`
|
||||
end
|
||||
|
||||
(* Names of various instructions *)
|
||||
|
||||
let name_for_comparison = function
|
||||
Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le"
|
||||
| Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt"
|
||||
| Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "leu"
|
||||
| Iunsigned Cge -> "geu" | Iunsigned Clt -> "ltu" | Iunsigned Cgt -> "gtu"
|
||||
|
||||
let name_for_float_comparison cmp neg =
|
||||
match cmp with
|
||||
Ceq -> ("eq", neg) | Cne -> ("eq", not neg)
|
||||
| Cle -> ("le", neg) | Cge -> ("ult", not neg)
|
||||
| Clt -> ("lt", neg) | Cgt -> ("ule", not neg)
|
||||
|
||||
let name_for_int_operation = function
|
||||
Iadd -> "addu"
|
||||
| Isub -> "subu"
|
||||
| Imul -> "mul"
|
||||
| Idiv -> "div"
|
||||
| Imod -> "rem"
|
||||
| Iand -> "and"
|
||||
| Ior -> "or"
|
||||
| Ixor -> "xor"
|
||||
| Ilsl -> "sll"
|
||||
| Ilsr -> "srl"
|
||||
| Iasr -> "sra"
|
||||
| Icomp cmp -> "s" ^ name_for_comparison cmp
|
||||
| _ -> Misc.fatal_error "Emit.name_for_int_operation"
|
||||
|
||||
let name_for_float_operation = function
|
||||
Inegf -> "neg.d"
|
||||
| Iabsf -> "abs.d"
|
||||
| Iaddf -> "add.d"
|
||||
| Isubf -> "sub.d"
|
||||
| Imulf -> "mul.d"
|
||||
| Idivf -> "div.d"
|
||||
| _ -> Misc.fatal_error "Emit.name_for_float_operation"
|
||||
|
||||
(* Output the assembly code for an instruction *)
|
||||
|
||||
(* Name of current function *)
|
||||
let function_name = ref ""
|
||||
(* Entry point for tail recursive calls *)
|
||||
let tailrec_entry_point = ref 0
|
||||
(* Label of jump to caml_call_gc *)
|
||||
let call_gc_label = ref 0
|
||||
(* Label of trap for out-of-range accesses *)
|
||||
let range_check_trap = ref 0
|
||||
|
||||
let emit_instr i =
|
||||
match i.desc with
|
||||
Lend -> ()
|
||||
| Lop(Imove | Ispill | Ireload) ->
|
||||
let src = i.arg.(0) and dst = i.res.(0) in
|
||||
if src.loc <> dst.loc then begin
|
||||
match (src, dst) with
|
||||
{loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} ->
|
||||
` move {emit_reg dst}, {emit_reg src}\n`
|
||||
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
|
||||
` mov.d {emit_reg dst}, {emit_reg src}\n`
|
||||
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Int|Addr} ->
|
||||
` mfc1.d {emit_reg dst}, {emit_reg src}\n`
|
||||
| {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} ->
|
||||
` sw {emit_reg src}, {emit_stack dst}\n`
|
||||
| {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
|
||||
` s.d {emit_reg src}, {emit_stack dst}\n`
|
||||
| {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} ->
|
||||
` lw {emit_reg dst}, {emit_stack src}\n`
|
||||
| {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
|
||||
` l.d {emit_reg dst}, {emit_stack src}\n`
|
||||
| _ ->
|
||||
fatal_error "Emit_mips: Imove"
|
||||
end
|
||||
| Lop(Iconst_int n) ->
|
||||
if Nativeint.sign n = 0 then
|
||||
` move {emit_reg i.res.(0)}, $0\n`
|
||||
else
|
||||
` li {emit_reg i.res.(0)}, {emit_nativeint n}\n`
|
||||
| Lop(Iconst_float s) ->
|
||||
` li.d {emit_reg i.res.(0)}, {emit_string s}\n`
|
||||
| Lop(Iconst_symbol s) ->
|
||||
` la {emit_reg i.res.(0)}, {emit_symbol s}\n`
|
||||
| Lop(Icall_ind) ->
|
||||
liveregs i 0;
|
||||
if pic then
|
||||
` move $25, {emit_reg i.arg.(0)}\n`;
|
||||
` jal {emit_reg i.arg.(0)}\n`;
|
||||
`{record_frame i.live}\n`;
|
||||
reload_gp()
|
||||
| Lop(Icall_imm s) ->
|
||||
liveregs i 0;
|
||||
` jal {emit_symbol s}\n`;
|
||||
`{record_frame i.live}\n`;
|
||||
reload_gp()
|
||||
| Lop(Itailcall_ind) ->
|
||||
let n = frame_size() in
|
||||
if !contains_calls then
|
||||
` lw $31, {emit_int(n - 4)}($sp)\n`;
|
||||
if n > 0 then
|
||||
` addu $sp, $sp, {emit_int n}\n`;
|
||||
liveregs i 0;
|
||||
if pic then
|
||||
` move $25, {emit_reg i.arg.(0)}\n`;
|
||||
` j {emit_reg i.arg.(0)}\n`
|
||||
| Lop(Itailcall_imm s) ->
|
||||
if s = !function_name then begin
|
||||
` b {emit_label !tailrec_entry_point}\n`
|
||||
end else begin
|
||||
let n = frame_size() in
|
||||
if !contains_calls then
|
||||
` lw $31, {emit_int(n - 4)}($sp)\n`;
|
||||
if n > 0 then
|
||||
` addu $sp, $sp, {emit_int n}\n`;
|
||||
liveregs i 0;
|
||||
emit_branch_symbol s
|
||||
end
|
||||
| Lop(Iextcall(s, alloc)) ->
|
||||
if alloc then begin
|
||||
` la $24, {emit_symbol s}\n`;
|
||||
liveregs i live_24;
|
||||
` jal caml_c_call\n`;
|
||||
`{record_frame i.live}\n`
|
||||
end else begin
|
||||
` jal {emit_symbol s}\n`
|
||||
end;
|
||||
reload_gp()
|
||||
| Lop(Istackoffset n) ->
|
||||
if n >= 0 then
|
||||
` subu $sp, $sp, {emit_int n}\n`
|
||||
else
|
||||
` addu $sp, $sp, {emit_int (-n)}\n`;
|
||||
stack_offset := !stack_offset + n
|
||||
| Lop(Iload(chunk, addr)) ->
|
||||
begin match i.res.(0).typ with
|
||||
Int | Addr ->
|
||||
let load_instr =
|
||||
match chunk with
|
||||
Word -> "lw"
|
||||
| Byte_unsigned -> "lbu"
|
||||
| Byte_signed -> "lb"
|
||||
| Sixteen_unsigned -> "lhu"
|
||||
| Sixteen_signed -> "lh" in
|
||||
` {emit_string load_instr} {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`
|
||||
| Float ->
|
||||
(* Destination is not necessarily 8-aligned, hence better not use l.d *)
|
||||
` lwc1 {emit_lower_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`;
|
||||
` lwc1 {emit_upper_reg i.res.(0)}, {emit_addressing (offset_addressing addr 4) i.arg 0}\n`
|
||||
end
|
||||
| Lop(Istore(chunk, addr)) ->
|
||||
begin match i.arg.(0).typ with
|
||||
Int | Addr ->
|
||||
let store_instr =
|
||||
match chunk with
|
||||
Word -> "sw"
|
||||
| Byte_unsigned | Byte_signed -> "sb"
|
||||
| Sixteen_unsigned | Sixteen_signed -> "sh" in
|
||||
` {emit_string store_instr} {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
|
||||
| Float ->
|
||||
(* Destination is not necessarily 8-aligned, hence better not use s.d *)
|
||||
` swc1 {emit_lower_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n`;
|
||||
` swc1 {emit_upper_reg i.arg.(0)}, {emit_addressing (offset_addressing addr 4) i.arg 1}\n`
|
||||
end
|
||||
| Lop(Ialloc n) ->
|
||||
if pic or !fastcode_flag then begin
|
||||
if !call_gc_label = 0 then call_gc_label := new_label();
|
||||
` .set noreorder\n`;
|
||||
` subu $22, $22, {emit_int n}\n`;
|
||||
` subu $24, $22, $23\n`;
|
||||
` bltzal $24, {emit_label !call_gc_label}\n`;
|
||||
` addu {emit_reg i.res.(0)}, $22, 4\n`;
|
||||
`{record_frame i.live}\n`;
|
||||
` .set reorder\n`
|
||||
end else begin
|
||||
begin match n with
|
||||
8 -> liveregs i 0;
|
||||
` jal caml_alloc1\n`
|
||||
| 12 -> liveregs i 0;
|
||||
` jal caml_alloc2\n`
|
||||
| 16 -> liveregs i 0;
|
||||
` jal caml_alloc3\n`
|
||||
| _ -> ` li $24, {emit_int n}\n`;
|
||||
liveregs i live_24;
|
||||
` jal caml_alloc\n`
|
||||
end;
|
||||
`{record_frame i.live}\n`;
|
||||
` addu {emit_reg i.res.(0)}, $22, 4\n`
|
||||
end
|
||||
| Lop(Iintop(Icheckbound)) ->
|
||||
if !range_check_trap = 0 then range_check_trap := new_label();
|
||||
` bleu {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label !range_check_trap}\n`
|
||||
| Lop(Iintop op) ->
|
||||
let instr = name_for_int_operation op in
|
||||
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
|
||||
| Lop(Iintop_imm(Icheckbound, n)) ->
|
||||
if !range_check_trap = 0 then range_check_trap := new_label();
|
||||
` bleu {emit_reg i.arg.(0)}, {emit_int n}, {emit_label !range_check_trap}\n`
|
||||
| Lop(Iintop_imm(op, n)) ->
|
||||
let instr = name_for_int_operation op in
|
||||
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n`
|
||||
| Lop(Inegf | Iabsf as op) ->
|
||||
let instr = name_for_float_operation op in
|
||||
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
|
||||
| Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
|
||||
let instr = name_for_float_operation op in
|
||||
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
|
||||
| Lop(Ifloatofint) ->
|
||||
` mtc1 {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`;
|
||||
` cvt.d.w {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Iintoffloat) ->
|
||||
` trunc.w.d $f10, {emit_reg i.arg.(0)}, $24\n`;
|
||||
` mfc1 {emit_reg i.res.(0)}, $f10\n`
|
||||
| Lop(Ispecific sop) ->
|
||||
fatal_error "Emit_mips: Ispecific"
|
||||
| Lreloadretaddr ->
|
||||
let n = frame_size() in
|
||||
` lw $31, {emit_int(n - 4)}($sp)\n`
|
||||
| Lreturn ->
|
||||
let n = frame_size() in
|
||||
if n > 0 then
|
||||
` addu $sp, $sp, {emit_int n}\n`;
|
||||
liveregs i 0;
|
||||
` j $31\n`
|
||||
| Llabel lbl ->
|
||||
`{emit_label lbl}:\n`
|
||||
| Lbranch lbl ->
|
||||
` b {emit_label lbl}\n`
|
||||
| Lcondbranch(tst, lbl) ->
|
||||
begin match tst with
|
||||
Itruetest ->
|
||||
` bne {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n`
|
||||
| Ifalsetest ->
|
||||
` beq {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n`
|
||||
| Iinttest cmp ->
|
||||
let comp = name_for_comparison cmp in
|
||||
` b{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label lbl}\n`
|
||||
| Iinttest_imm(cmp, n) ->
|
||||
let comp = name_for_comparison cmp in
|
||||
` b{emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}, {emit_label lbl}\n`
|
||||
| Ifloattest(cmp, neg) ->
|
||||
let (comp, branch) = name_for_float_comparison cmp neg in
|
||||
` c.{emit_string comp}.d {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
if branch
|
||||
then ` bc1f {emit_label lbl}\n`
|
||||
else ` bc1t {emit_label lbl}\n`
|
||||
| Ioddtest ->
|
||||
` and $24, {emit_reg i.arg.(0)}, 1\n`;
|
||||
` bne $24, $0, {emit_label lbl}\n`
|
||||
| Ieventest ->
|
||||
` and $24, {emit_reg i.arg.(0)}, 1\n`;
|
||||
` beq $24, $0, {emit_label lbl}\n`
|
||||
end
|
||||
| Lcondbranch3(lbl0, lbl1, lbl2) ->
|
||||
` subu $24, {emit_reg i.arg.(0)}, 1\n`;
|
||||
begin match lbl0 with
|
||||
None -> ()
|
||||
| Some lbl -> ` beq {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n`
|
||||
end;
|
||||
begin match lbl1 with
|
||||
None -> ()
|
||||
| Some lbl -> ` beq $24, $0, {emit_label lbl}\n`
|
||||
end;
|
||||
begin match lbl2 with
|
||||
None -> ()
|
||||
| Some lbl -> ` bgtz $24, {emit_label lbl}\n`
|
||||
end
|
||||
| Lswitch jumptbl ->
|
||||
let lbl_jumptbl = new_label() in
|
||||
` sll $24, {emit_reg i.arg.(0)}, 2\n`;
|
||||
` lw $24, {emit_label lbl_jumptbl}($24)\n`;
|
||||
if pic then
|
||||
` .cpadd $24\n`;
|
||||
liveregs i live_24;
|
||||
` j $24\n`;
|
||||
` .rdata\n`;
|
||||
`{emit_label lbl_jumptbl}:\n`;
|
||||
for i = 0 to Array.length jumptbl - 1 do
|
||||
if pic
|
||||
then ` .gpword {emit_label jumptbl.(i)}\n`
|
||||
else ` .word {emit_label jumptbl.(i)}\n`
|
||||
done;
|
||||
` .text\n`
|
||||
| Lsetuptrap lbl ->
|
||||
` subu $sp, $sp, 8\n`;
|
||||
` bal {emit_label lbl}\n`;
|
||||
reload_gp()
|
||||
| Lpushtrap ->
|
||||
stack_offset := !stack_offset + 8;
|
||||
` sw $30, 0($sp)\n`;
|
||||
` sw $31, 4($sp)\n`;
|
||||
` move $30, $sp\n`
|
||||
| Lpoptrap ->
|
||||
` lw $30, 0($sp)\n`;
|
||||
` addu $sp, $sp, 8\n`;
|
||||
stack_offset := !stack_offset - 8
|
||||
| Lraise ->
|
||||
` lw $25, 4($30)\n`;
|
||||
` move $sp, $30\n`;
|
||||
` lw $30, 0($sp)\n`;
|
||||
` addu $sp, $sp, 8\n`;
|
||||
liveregs i 0;
|
||||
` jal $25\n` (* Keep retaddr in $31 for debugging *)
|
||||
|
||||
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;
|
||||
fastcode_flag := fundecl.fun_fast;
|
||||
uses_gp := pic && instr_uses_gp fundecl.fun_body;
|
||||
tailrec_entry_point := new_label();
|
||||
stack_offset := 0;
|
||||
call_gc_label := 0;
|
||||
range_check_trap := 0;
|
||||
` .text\n`;
|
||||
` .align 2\n`;
|
||||
` .globl {emit_symbol fundecl.fun_name}\n`;
|
||||
` .ent {emit_symbol fundecl.fun_name}\n`;
|
||||
`{emit_symbol fundecl.fun_name}:\n`;
|
||||
if !uses_gp then begin
|
||||
` .set noreorder\n`;
|
||||
` .cpload $25\n`;
|
||||
` .set reorder\n`
|
||||
end;
|
||||
let n = frame_size() in
|
||||
if n > 0 then
|
||||
` subu $sp, $sp, {emit_int n}\n`;
|
||||
if !contains_calls then
|
||||
` sw $31, {emit_int(n - 4)}($sp)\n`;
|
||||
if !uses_gp && !contains_calls then
|
||||
` sw $gp, {emit_int(n - 8)}($sp)\n`;
|
||||
`{emit_label !tailrec_entry_point}:\n`;
|
||||
emit_all fundecl.fun_body;
|
||||
if !call_gc_label > 0 then begin
|
||||
`{emit_label !call_gc_label}:\n`;
|
||||
emit_branch_symbol "caml_call_gc"
|
||||
end;
|
||||
if !range_check_trap > 0 then begin
|
||||
`{emit_label !range_check_trap}:\n`;
|
||||
emit_branch_symbol "array_bound_error"
|
||||
end;
|
||||
` .end {emit_symbol fundecl.fun_name}\n`
|
||||
|
||||
(* Emission of data *)
|
||||
|
||||
let emit_item = function
|
||||
Cdefine_symbol s ->
|
||||
` .globl {emit_symbol s}\n`;
|
||||
`{emit_symbol s}:\n`
|
||||
| Cdefine_label lbl ->
|
||||
`{emit_label (10000 + lbl)}:\n`
|
||||
| Cint8 n ->
|
||||
` .byte {emit_int n}\n`
|
||||
| Cint16 n ->
|
||||
` .half {emit_int n}\n`
|
||||
| Cint n ->
|
||||
` .word {emit_nativeint n}\n`
|
||||
| Cfloat f ->
|
||||
` .align 0\n`; (* Prevent alignment on 8-byte boundary *)
|
||||
` .double {emit_string f}\n`
|
||||
| Csymbol_address s ->
|
||||
` .word {emit_symbol s}\n`
|
||||
| Clabel_address lbl ->
|
||||
` .word {emit_label (10000 + lbl)}\n`
|
||||
| Cstring s ->
|
||||
emit_string_directive " .ascii " s
|
||||
| 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() =
|
||||
(* There are really two groups of registers:
|
||||
$sp and $30 always point to stack locations
|
||||
$2 - $21 never point to stack locations. *)
|
||||
` .noalias $2,$sp; .noalias $2,$30; .noalias $3,$sp; .noalias $3,$30\n`;
|
||||
` .noalias $4,$sp; .noalias $4,$30; .noalias $5,$sp; .noalias $5,$30\n`;
|
||||
` .noalias $6,$sp; .noalias $6,$30; .noalias $7,$sp; .noalias $7,$30\n`;
|
||||
` .noalias $8,$sp; .noalias $8,$30; .noalias $9,$sp; .noalias $9,$30\n`;
|
||||
` .noalias $10,$sp; .noalias $10,$30; .noalias $11,$sp; .noalias $11,$30\n`;
|
||||
` .noalias $12,$sp; .noalias $12,$30; .noalias $13,$sp; .noalias $13,$30\n`;
|
||||
` .noalias $14,$sp; .noalias $14,$30; .noalias $15,$sp; .noalias $15,$30\n`;
|
||||
` .noalias $16,$sp; .noalias $16,$30; .noalias $17,$sp; .noalias $17,$30\n`;
|
||||
` .noalias $18,$sp; .noalias $18,$30; .noalias $19,$sp; .noalias $19,$30\n`;
|
||||
` .noalias $20,$sp; .noalias $20,$30; .noalias $21,$sp; .noalias $21,$30\n\n`;
|
||||
(* The following .file directive is intended to prevent the generation
|
||||
of line numbers for the debugger, since they make .o files larger. *)
|
||||
` .file 1 \"{emit_string !Location.input_name}\"\n\n`;
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
|
||||
` .data\n`;
|
||||
` .globl {emit_symbol lbl_begin}\n`;
|
||||
`{emit_symbol lbl_begin}:\n`;
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
|
||||
` .text\n`;
|
||||
` .globl {emit_symbol lbl_begin}\n`;
|
||||
`{emit_symbol lbl_begin}:\n`
|
||||
|
||||
let end_assembly () =
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
|
||||
` .text\n`;
|
||||
` .globl {emit_symbol lbl_end}\n`;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_end" in
|
||||
` .data\n`;
|
||||
` .globl {emit_symbol lbl_end}\n`;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
` .word 0\n`;
|
||||
let lbl = Compilenv.current_unit_name() ^ "_frametable" in
|
||||
` .rdata\n`;
|
||||
` .globl {emit_symbol lbl}\n`;
|
||||
`{emit_symbol lbl}:\n`;
|
||||
` .word {emit_int (List.length !frame_descriptors)}\n`;
|
||||
List.iter emit_frame !frame_descriptors;
|
||||
frame_descriptors := []
|
||||
|
|
@ -1,877 +0,0 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Emission of PowerPC assembly code *)
|
||||
|
||||
module StringSet = Set.Make(struct type t = string let compare = compare end)
|
||||
|
||||
open Misc
|
||||
open Cmm
|
||||
open Arch
|
||||
open Proc
|
||||
open Reg
|
||||
open Mach
|
||||
open Linearize
|
||||
open Emitaux
|
||||
|
||||
(* Distinguish between the PowerPC and the RS6000 submodels *)
|
||||
|
||||
let powerpc =
|
||||
match Config.model with
|
||||
"ppc" -> true
|
||||
| "rs6000" -> false
|
||||
| _ -> fatal_error "wrong $(MODEL)"
|
||||
|
||||
(* Distinguish between the PowerOpen (AIX, MacOS) relative-addressing model
|
||||
and the SVR4 (Solaris, MkLinux) absolute-addressing model. *)
|
||||
|
||||
let toc =
|
||||
match Config.system with
|
||||
"aix" -> true
|
||||
| "elf" -> false
|
||||
| _ -> fatal_error "wrong $(SYSTEM)"
|
||||
|
||||
(* Layout of the stack *)
|
||||
|
||||
(* In the TOC-based model:
|
||||
The bottom 24 bytes of the stack are reserved at all times
|
||||
for a standard linkage area.
|
||||
In this area, the word at offset +20 is used by glue code and others to
|
||||
save the TOC register.
|
||||
The bottom two words are used as temporaries and for trap frames.
|
||||
The stack is kept 8-aligned.
|
||||
In the absolute-address model:
|
||||
No reserved space at the bottom of the stack.
|
||||
The stack is kept 8-aligned. *)
|
||||
|
||||
let stack_linkage_area = if toc then 24 else 0
|
||||
let trap_frame_size = if toc then 24 else 8
|
||||
|
||||
let stack_offset = ref 0
|
||||
|
||||
let frame_size () =
|
||||
let size =
|
||||
stack_linkage_area + (* The bottom linkage area *)
|
||||
!stack_offset + (* Trap frame, outgoing parameters *)
|
||||
4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + (* Local variables *)
|
||||
(if !contains_calls then 4 else 0) in (* The return address *)
|
||||
Misc.align size 8
|
||||
|
||||
let slot_offset loc cls =
|
||||
match loc with
|
||||
Local n ->
|
||||
if cls = 0
|
||||
then stack_linkage_area + !stack_offset + num_stack_slots.(1) * 8 + n * 4
|
||||
else stack_linkage_area + !stack_offset + n * 8
|
||||
| Incoming n -> frame_size() + n
|
||||
| Outgoing n -> n
|
||||
|
||||
(* Output a symbol *)
|
||||
|
||||
let emit_symbol s =
|
||||
Emitaux.emit_symbol '.' s
|
||||
|
||||
let emit_codesymbol s =
|
||||
if toc then emit_char '.';
|
||||
emit_symbol s
|
||||
|
||||
(* Output a label *)
|
||||
|
||||
let label_prefix = if toc then "L.." else ".L"
|
||||
|
||||
let emit_label lbl =
|
||||
emit_string label_prefix; emit_int lbl
|
||||
|
||||
(* Section switching *)
|
||||
|
||||
let data_space =
|
||||
if toc
|
||||
then " .csect .data[RW]\n"
|
||||
else " .section \".data\"\n"
|
||||
|
||||
let code_space =
|
||||
if toc
|
||||
then " .csect .text[PR]\n"
|
||||
else " .section \".text\"\n"
|
||||
|
||||
(* 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 `{emit_int ofs}(1)`
|
||||
| _ -> fatal_error "Emit.emit_stack"
|
||||
|
||||
(* Split a 32-bit integer constants in two 16-bit halves *)
|
||||
|
||||
let low n = n land 0xFFFF
|
||||
let high n = n asr 16
|
||||
|
||||
let nativelow n = Nativeint.to_int n land 0xFFFF
|
||||
let nativehigh n = Nativeint.to_int (Nativeint.shift n (-16))
|
||||
|
||||
let is_native_immediate n =
|
||||
Nativeint.cmp n 32767 <= 0 && Nativeint.cmp n (-32768) >= 0
|
||||
|
||||
(* Output a load or store operation *)
|
||||
|
||||
let emit_symbol_offset s d =
|
||||
emit_symbol s;
|
||||
if d > 0 then `+`;
|
||||
if d <> 0 then emit_int d
|
||||
|
||||
let emit_load_store instr addressing_mode addr n arg =
|
||||
match addressing_mode with
|
||||
Ibased(s, d) ->
|
||||
(* Only relevant in the absolute model *)
|
||||
` addis 11, 0, {emit_symbol_offset s d}@ha\n`;
|
||||
` {emit_string instr} {emit_reg arg}, {emit_symbol_offset s d}@l(11)\n`
|
||||
| Iindexed ofs ->
|
||||
if is_immediate ofs then
|
||||
` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n`
|
||||
else begin
|
||||
` lis 0, {emit_int(high ofs)}\n`;
|
||||
if low ofs <> 0 then
|
||||
` ori 0, 0, {emit_int(low ofs)}\n`;
|
||||
` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, 0\n`
|
||||
end
|
||||
| Iindexed2 ->
|
||||
` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_reg addr.(n+1)}\n`
|
||||
|
||||
(* After a comparison, extract the result as 0 or 1 *)
|
||||
|
||||
let emit_set_comp cmp res =
|
||||
` mfcr 0\n`;
|
||||
let bitnum =
|
||||
match cmp with
|
||||
Ceq | Cne -> 2
|
||||
| Cgt | Cle -> 1
|
||||
| Clt | Cge -> 0 in
|
||||
` rlwinm {emit_reg res}, 0, {emit_int(bitnum+1)}, 1\n`;
|
||||
begin match cmp with
|
||||
Cne | Cle | Cge -> ` xori {emit_reg res}, {emit_reg res}, 1\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 := (r lsl 1) + 1 :: !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`;
|
||||
` .short {emit_int fd.fd_frame_size}\n`;
|
||||
` .short {emit_int (List.length fd.fd_live_offset)}\n`;
|
||||
List.iter
|
||||
(fun n ->
|
||||
` .short {emit_int n}\n`)
|
||||
fd.fd_live_offset;
|
||||
` .align 2\n`
|
||||
|
||||
(* Record symbols and floating-point constants (for the TOC model).
|
||||
These will go in the toc section. *)
|
||||
|
||||
let label_constant table constant =
|
||||
try
|
||||
Hashtbl.find table constant
|
||||
with Not_found ->
|
||||
let lbl = new_label() in
|
||||
Hashtbl.add table constant lbl;
|
||||
lbl
|
||||
|
||||
let symbol_constants = (Hashtbl.create 17 : (string, int) Hashtbl.t)
|
||||
let float_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t)
|
||||
|
||||
let label_symbol s = label_constant symbol_constants s
|
||||
let label_float s = label_constant float_constants s
|
||||
|
||||
let emit_symbol_constant symb lbl =
|
||||
`{emit_label lbl}: .tc {emit_symbol symb}[TC], {emit_symbol symb}\n`
|
||||
|
||||
let emit_float_constant float lbl =
|
||||
`{emit_label lbl}: .tc FD_`;
|
||||
for i = 0 to 7 do
|
||||
emit_printf "%02x" (Char.code (String.unsafe_get float i))
|
||||
done;
|
||||
`[TC], 0x`;
|
||||
for i = 0 to 3 do
|
||||
emit_printf "%02x" (Char.code (String.unsafe_get float i))
|
||||
done;
|
||||
`, 0x`;
|
||||
for i = 4 to 7 do
|
||||
emit_printf "%02x" (Char.code (String.unsafe_get float i))
|
||||
done;
|
||||
`\n`
|
||||
|
||||
(* Record floating-point literals (for the ELF model) *)
|
||||
|
||||
let float_literals = ref ([] : (string * int) list)
|
||||
|
||||
(* Names for conditional branches after comparisons *)
|
||||
|
||||
let branch_for_comparison = function
|
||||
Ceq -> "beq" | Cne -> "bne"
|
||||
| Cle -> "ble" | Cgt -> "bgt"
|
||||
| Cge -> "bge" | Clt -> "blt"
|
||||
|
||||
let name_for_int_comparison = function
|
||||
Isigned cmp -> ("cmpw", branch_for_comparison cmp)
|
||||
| Iunsigned cmp -> ("cmplw", branch_for_comparison cmp)
|
||||
|
||||
(* Names for various instructions *)
|
||||
|
||||
let name_for_intop = function
|
||||
Iadd -> "add"
|
||||
| Imul -> "mullw"
|
||||
| Idiv -> if powerpc then "divw" else "divs"
|
||||
| Iand -> "and"
|
||||
| Ior -> "or"
|
||||
| Ixor -> "xor"
|
||||
| Ilsl -> "slw"
|
||||
| Ilsr -> "srw"
|
||||
| Iasr -> "sraw"
|
||||
| _ -> Misc.fatal_error "Emit.Intop"
|
||||
|
||||
let name_for_intop_imm = function
|
||||
Iadd -> "addi"
|
||||
| Imul -> "mulli"
|
||||
| Iand -> "andi."
|
||||
| Ior -> "ori"
|
||||
| Ixor -> "xori"
|
||||
| Ilsl -> "slwi"
|
||||
| Ilsr -> "srwi"
|
||||
| Iasr -> "srawi"
|
||||
| _ -> Misc.fatal_error "Emit.Intop_imm"
|
||||
|
||||
let name_for_floatop1 = function
|
||||
Inegf -> "fneg"
|
||||
| Iabsf -> "fabs"
|
||||
| _ -> Misc.fatal_error "Emit.Iopf1"
|
||||
|
||||
let name_for_floatop2 = function
|
||||
Iaddf -> "fadd"
|
||||
| Isubf -> "fsub"
|
||||
| Imulf -> "fmul"
|
||||
| Idivf -> "fdiv"
|
||||
| _ -> Misc.fatal_error "Emit.Iopf2"
|
||||
|
||||
let name_for_specific = function
|
||||
Imultaddf -> "fmadd"
|
||||
| Imultsubf -> "fmsub"
|
||||
|
||||
(* Name of current function *)
|
||||
let function_name = ref ""
|
||||
(* Entry point for tail recursive calls *)
|
||||
let tailrec_entry_point = ref 0
|
||||
(* Names of functions defined in the current file *)
|
||||
let defined_functions = ref StringSet.empty
|
||||
(* Label of glue code for calling the GC *)
|
||||
let call_gc_label = ref 0
|
||||
(* Label of jump table *)
|
||||
let lbl_jumptbl = ref 0
|
||||
(* List of all labels in jumptable (reverse order) *)
|
||||
let jumptbl_entries = ref []
|
||||
(* Number of jumptable entries *)
|
||||
let num_jumptbl_entries = ref 0
|
||||
|
||||
(* Output the assembly code for an instruction *)
|
||||
|
||||
let rec emit_instr i dslot =
|
||||
match i.desc with
|
||||
Lend -> ()
|
||||
| Lop(Imove | Ispill | Ireload) ->
|
||||
let src = i.arg.(0) and dst = i.res.(0) in
|
||||
if src.loc <> dst.loc then begin
|
||||
match (src, dst) with
|
||||
{loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} ->
|
||||
` mr {emit_reg dst}, {emit_reg src}\n`
|
||||
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
|
||||
` fmr {emit_reg dst}, {emit_reg src}\n`
|
||||
| {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} ->
|
||||
` stw {emit_reg src}, {emit_stack dst}\n`
|
||||
| {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
|
||||
` stfd {emit_reg src}, {emit_stack dst}\n`
|
||||
| {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} ->
|
||||
` lwz {emit_reg dst}, {emit_stack src}\n`
|
||||
| {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
|
||||
` lfd {emit_reg dst}, {emit_stack src}\n`
|
||||
| (_, _) ->
|
||||
fatal_error "Emit: Imove"
|
||||
end
|
||||
| Lop(Iconst_int n) ->
|
||||
if is_native_immediate n then
|
||||
` li {emit_reg i.res.(0)}, {emit_nativeint n}\n`
|
||||
else begin
|
||||
` lis {emit_reg i.res.(0)}, {emit_int(nativehigh n)}\n`;
|
||||
if nativelow n <> 0 then
|
||||
` ori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int(nativelow n)}\n`
|
||||
end
|
||||
| Lop(Iconst_float s) ->
|
||||
if toc then begin
|
||||
let repr = (Obj.magic (float_of_string s) : string) in
|
||||
let lbl = label_float repr in
|
||||
` lfd {emit_reg i.res.(0)}, {emit_label lbl}(2) # {emit_string s}\n`
|
||||
end else begin
|
||||
let lbl = new_label() in
|
||||
float_literals := (s, lbl) :: !float_literals;
|
||||
` addis 11, 0, {emit_label lbl}@ha\n`;
|
||||
` lfd {emit_reg i.res.(0)}, {emit_label lbl}@l(11)\n`
|
||||
end
|
||||
| Lop(Iconst_symbol s) ->
|
||||
if toc then begin
|
||||
let lbl = label_symbol s in
|
||||
` lwz {emit_reg i.res.(0)}, {emit_label lbl}(2) # {emit_symbol s}\n`
|
||||
end else begin
|
||||
` addis {emit_reg i.res.(0)}, 0, {emit_symbol s}@ha\n`;
|
||||
` addi {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_symbol s}@l\n`
|
||||
end
|
||||
| Lop(Icall_ind) ->
|
||||
if toc then begin
|
||||
` lwz 0, 0({emit_reg i.arg.(0)})\n`;
|
||||
` stw 2, 20(1)\n`;
|
||||
` mtlr 0\n`;
|
||||
` lwz 2, 4({emit_reg i.arg.(0)})\n`;
|
||||
record_frame i.live;
|
||||
` blrl\n`;
|
||||
` lwz 2, 20(1)\n`
|
||||
end else begin
|
||||
` mtlr {emit_reg i.arg.(0)}\n`;
|
||||
record_frame i.live;
|
||||
` blrl\n`
|
||||
end
|
||||
| Lop(Icall_imm s) ->
|
||||
record_frame i.live;
|
||||
` bl {emit_codesymbol s}\n`;
|
||||
if toc && not (StringSet.mem s !defined_functions) then
|
||||
` cror 31, 31, 31\n` (* nop *)
|
||||
| Lop(Itailcall_ind) ->
|
||||
let n = frame_size() in
|
||||
if toc then begin
|
||||
` lwz 0, 0({emit_reg i.arg.(0)})\n`;
|
||||
` lwz 2, 4({emit_reg i.arg.(0)})\n`;
|
||||
` mtctr 0\n`
|
||||
end else begin
|
||||
` mtctr {emit_reg i.arg.(0)}\n`
|
||||
end;
|
||||
if !contains_calls then begin
|
||||
` lwz 11, {emit_int(n - 4)}(1)\n`;
|
||||
` addi 1, 1, {emit_int n}\n`;
|
||||
` mtlr 11\n`
|
||||
end else begin
|
||||
` addi 1, 1, {emit_int n}\n`
|
||||
end;
|
||||
` bctr\n`
|
||||
| Lop(Itailcall_imm s) ->
|
||||
if s = !function_name then
|
||||
` b {emit_label !tailrec_entry_point}\n`
|
||||
else if not toc || StringSet.mem s !defined_functions then begin
|
||||
let n = frame_size() in
|
||||
if !contains_calls then begin
|
||||
` lwz 11, {emit_int(n - 4)}(1)\n`;
|
||||
` addi 1, 1, {emit_int n}\n`;
|
||||
` mtlr 11\n`
|
||||
end else begin
|
||||
` addi 1, 1, {emit_int n}\n`
|
||||
end;
|
||||
` b {emit_codesymbol s}\n`
|
||||
end else begin
|
||||
(* Tailcalling a function that has a possibly different TOC
|
||||
is difficult, because the callee's TOC must be loaded in r2,
|
||||
but ours must not be stored in 20(r1), which would overwrite
|
||||
our caller's saved TOC. Hence we can't go through the
|
||||
standard glue code. Here, we just proceed as in tailcall_ind. *)
|
||||
let lbl = label_symbol s in
|
||||
let n = frame_size() in
|
||||
` lwz 12, {emit_label lbl}(2) # {emit_symbol s}\n`;
|
||||
if !contains_calls then begin
|
||||
` lwz 11, {emit_int(n - 4)}(1)\n`;
|
||||
` lwz 0, 0(12)\n`;
|
||||
` lwz 2, 4(12)\n`;
|
||||
` mtctr 0\n`;
|
||||
` addi 1, 1, {emit_int n}\n`;
|
||||
` mtlr 11\n`
|
||||
end else begin
|
||||
` lwz 0, 0(12)\n`;
|
||||
` lwz 2, 4(12)\n`;
|
||||
` mtctr 0\n`;
|
||||
` addi 1, 1, {emit_int n}\n`
|
||||
end;
|
||||
` bctr\n`
|
||||
end
|
||||
| Lop(Iextcall(s, alloc)) ->
|
||||
if alloc then begin
|
||||
if toc then begin
|
||||
let lbl = label_symbol s in
|
||||
` lwz 11, {emit_label lbl}(2) # {emit_symbol s}\n`
|
||||
end else begin
|
||||
` addis 11, 0, {emit_symbol s}@ha\n`;
|
||||
` addi 11, 11, {emit_symbol s}@l\n`
|
||||
end;
|
||||
record_frame i.live;
|
||||
` bl {emit_codesymbol "caml_c_call"}\n`
|
||||
end else begin
|
||||
` bl {emit_codesymbol s}\n`
|
||||
end;
|
||||
if toc then
|
||||
` cror 31, 31, 31\n` (* nop *)
|
||||
| Lop(Istackoffset n) ->
|
||||
` addi 1, 1, {emit_int (-n)}\n`;
|
||||
stack_offset := !stack_offset + n
|
||||
| Lop(Iload(chunk, addr)) ->
|
||||
let loadinstr =
|
||||
match chunk with
|
||||
Word -> if i.res.(0).typ = Float then "lfd" else "lwz"
|
||||
| Byte_unsigned -> "lbz"
|
||||
| Byte_signed -> "lbz"
|
||||
| Sixteen_unsigned -> "lhz"
|
||||
| Sixteen_signed -> "lha" in
|
||||
emit_load_store loadinstr addr i.arg 0 i.res.(0);
|
||||
if chunk = Byte_signed then
|
||||
` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Istore(chunk, addr)) ->
|
||||
let storeinstr =
|
||||
match chunk with
|
||||
Word -> if i.arg.(0).typ = Float then "stfd" else "stw"
|
||||
| Byte_unsigned | Byte_signed -> "stb"
|
||||
| Sixteen_unsigned | Sixteen_signed -> "sth" in
|
||||
emit_load_store storeinstr addr i.arg 1 i.arg.(0)
|
||||
| Lop(Ialloc n) ->
|
||||
if !call_gc_label = 0 then call_gc_label := new_label();
|
||||
` addi 31, 31, {emit_int(-n)}\n`;
|
||||
` cmplw 31, 30\n`;
|
||||
` addi {emit_reg i.res.(0)}, 31, 4\n`;
|
||||
record_frame i.live;
|
||||
` bltl {emit_label !call_gc_label}\n`
|
||||
| Lop(Iintop Isub) -> (* subf has swapped arguments *)
|
||||
(* Use subfc instead of subf for RS6000 compatibility. *)
|
||||
` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
|
||||
| Lop(Iintop Imod) ->
|
||||
if powerpc then begin
|
||||
` divw 0, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
` mullw 0, 0, {emit_reg i.arg.(1)}\n`;
|
||||
` subfc {emit_reg i.res.(0)}, 0, {emit_reg i.arg.(0)}\n`
|
||||
end else begin
|
||||
` divs 0, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
` mfmq {emit_reg i.res.(0)}\n`
|
||||
end
|
||||
| Lop(Iintop(Icomp cmp)) ->
|
||||
begin match cmp with
|
||||
Isigned c ->
|
||||
` cmpw {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
emit_set_comp c i.res.(0)
|
||||
| Iunsigned c ->
|
||||
` cmplw {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
emit_set_comp c i.res.(0)
|
||||
end
|
||||
| Lop(Iintop Icheckbound) ->
|
||||
` twlle {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
|
||||
| Lop(Iintop op) ->
|
||||
let instr = name_for_intop op in
|
||||
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
|
||||
| Lop(Iintop_imm(Isub, n)) ->
|
||||
` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n`
|
||||
| Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *)
|
||||
let l = Misc.log2 n in
|
||||
` srawi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`;
|
||||
` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *)
|
||||
let l = Misc.log2 n in
|
||||
` srawi 0, {emit_reg i.arg.(0)}, {emit_int l}\n`;
|
||||
` addze 0, 0\n`;
|
||||
` slwi 0, 0, {emit_int l}\n`;
|
||||
` subfc {emit_reg i.res.(0)}, 0, {emit_reg i.arg.(0)}\n`
|
||||
| Lop(Iintop_imm(Icomp cmp, n)) ->
|
||||
begin match cmp with
|
||||
Isigned c ->
|
||||
` cmpwi {emit_reg i.arg.(0)}, {emit_int n}\n`;
|
||||
emit_set_comp c i.res.(0)
|
||||
| Iunsigned c ->
|
||||
` cmplwi {emit_reg i.arg.(0)}, {emit_int n}\n`;
|
||||
emit_set_comp c i.res.(0)
|
||||
end
|
||||
| Lop(Iintop_imm(Icheckbound, n)) ->
|
||||
` twllei {emit_reg i.arg.(0)}, {emit_int n}\n`
|
||||
| Lop(Iintop_imm(op, n)) ->
|
||||
let instr = name_for_intop_imm op in
|
||||
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n`
|
||||
| Lop(Inegf | Iabsf as op) ->
|
||||
let instr = name_for_floatop1 op in
|
||||
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
|
||||
| Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
|
||||
let instr = name_for_floatop2 op in
|
||||
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
|
||||
| Lop(Ifloatofint) ->
|
||||
if toc then begin
|
||||
let lbl = label_float "\067\048\000\000\128\000\000\000" in
|
||||
(* That string above represents 0x4330000080000000 *)
|
||||
` lfd 0, {emit_label lbl}(2)\n`
|
||||
end else begin
|
||||
let lbl = new_label() in
|
||||
float_literals := ("4.503601774854144e15", lbl) :: !float_literals;
|
||||
(* That float above also represents 0x4330000080000000 *)
|
||||
` addis 11, 0, {emit_label lbl}@ha\n`;
|
||||
` lfd 0, {emit_label lbl}@l(11)\n`
|
||||
end;
|
||||
` lis 0, 0x4330\n`;
|
||||
` stwu 0, -8(1)\n`;
|
||||
` xoris 0, {emit_reg i.arg.(0)}, 0x8000\n`;
|
||||
` stw 0, 4(1)\n`;
|
||||
` lfd {emit_reg i.res.(0)}, 0(1)\n`;
|
||||
` addi 1, 1, 8\n`;
|
||||
` fsub {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 0\n`
|
||||
| Lop(Iintoffloat) ->
|
||||
` fctiwz 0, {emit_reg i.arg.(0)}\n`;
|
||||
` stfdu 0, -8(1)\n`;
|
||||
` lwz {emit_reg i.res.(0)}, 4(1)\n`;
|
||||
` addi 1, 1, 8\n`
|
||||
| Lop(Ispecific sop) ->
|
||||
let instr = name_for_specific sop in
|
||||
` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`
|
||||
| Lreloadretaddr ->
|
||||
let n = frame_size() in
|
||||
` lwz 11, {emit_int(n - 4)}(1)\n`;
|
||||
` mtlr 11\n`
|
||||
| Lreturn ->
|
||||
let n = frame_size() in
|
||||
` addi 1, 1, {emit_int n}\n`;
|
||||
` blr\n`
|
||||
| Llabel lbl ->
|
||||
`{emit_label lbl}:\n`
|
||||
| Lbranch lbl ->
|
||||
` b {emit_label lbl}\n`
|
||||
| Lcondbranch(tst, lbl) ->
|
||||
begin match tst with
|
||||
Itruetest ->
|
||||
` cmpwi {emit_reg i.arg.(0)}, 0\n`;
|
||||
emit_delay dslot;
|
||||
` bne {emit_label lbl}\n`
|
||||
| Ifalsetest ->
|
||||
` cmpwi {emit_reg i.arg.(0)}, 0\n`;
|
||||
emit_delay dslot;
|
||||
` beq {emit_label lbl}\n`
|
||||
| Iinttest cmp ->
|
||||
let (comp, branch) = name_for_int_comparison cmp in
|
||||
` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
emit_delay dslot;
|
||||
` {emit_string branch} {emit_label lbl}\n`
|
||||
| Iinttest_imm(cmp, n) ->
|
||||
let (comp, branch) = name_for_int_comparison cmp in
|
||||
` {emit_string comp}i {emit_reg i.arg.(0)}, {emit_int n}\n`;
|
||||
emit_delay dslot;
|
||||
` {emit_string branch} {emit_label lbl}\n`
|
||||
| Ifloattest(cmp, neg) ->
|
||||
` fcmpu 0, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
(* bit 0 = lt, bit 1 = gt, bit 2 = eq *)
|
||||
let (bitnum, negtst) =
|
||||
match cmp with
|
||||
Ceq -> (2, neg)
|
||||
| Cne -> (2, not neg)
|
||||
| Cle -> ` cror 3, 0, 2\n`; (* lt or eq *)
|
||||
(3, neg)
|
||||
| Cgt -> (1, neg)
|
||||
| Cge -> ` cror 3, 1, 2\n`; (* gt or eq *)
|
||||
(3, neg)
|
||||
| Clt -> (0, neg) in
|
||||
emit_delay dslot;
|
||||
if negtst
|
||||
then ` bf {emit_int bitnum}, {emit_label lbl}\n`
|
||||
else ` bt {emit_int bitnum}, {emit_label lbl}\n`
|
||||
| Ioddtest ->
|
||||
` andi. 0, {emit_reg i.arg.(0)}, 1\n`;
|
||||
emit_delay dslot;
|
||||
` bne {emit_label lbl}\n`
|
||||
| Ieventest ->
|
||||
` andi. 0, {emit_reg i.arg.(0)}, 1\n`;
|
||||
emit_delay dslot;
|
||||
` beq {emit_label lbl}\n`
|
||||
end
|
||||
| Lcondbranch3(lbl0, lbl1, lbl2) ->
|
||||
` cmpwi {emit_reg i.arg.(0)}, 1\n`;
|
||||
emit_delay dslot;
|
||||
begin match lbl0 with
|
||||
None -> ()
|
||||
| Some lbl -> ` blt {emit_label lbl}\n`
|
||||
end;
|
||||
begin match lbl1 with
|
||||
None -> ()
|
||||
| Some lbl -> ` beq {emit_label lbl}\n`
|
||||
end;
|
||||
begin match lbl2 with
|
||||
None -> ()
|
||||
| Some lbl -> ` bgt {emit_label lbl}\n`
|
||||
end
|
||||
| Lswitch jumptbl ->
|
||||
if !lbl_jumptbl = 0 then lbl_jumptbl := new_label();
|
||||
if toc then begin
|
||||
` lwz 11, {emit_label !lbl_jumptbl}(2)\n`
|
||||
end else begin
|
||||
` addis 11, 0, {emit_label !lbl_jumptbl}@ha\n`;
|
||||
` addi 11, 11, {emit_label !lbl_jumptbl}@l\n`
|
||||
end;
|
||||
` addi 0, {emit_reg i.arg.(0)}, {emit_int !num_jumptbl_entries}\n`;
|
||||
` slwi 0, 0, 2\n`;
|
||||
` lwzx 0, 11, 0\n`;
|
||||
` add 0, 11, 0\n`;
|
||||
` mtctr 0\n`;
|
||||
` bctr\n`;
|
||||
for i = 0 to Array.length jumptbl - 1 do
|
||||
jumptbl_entries := jumptbl.(i) :: !jumptbl_entries;
|
||||
incr num_jumptbl_entries
|
||||
done
|
||||
| Lsetuptrap lbl ->
|
||||
` bl {emit_label lbl}\n`
|
||||
| Lpushtrap ->
|
||||
stack_offset := !stack_offset + trap_frame_size;
|
||||
` mflr 0\n`;
|
||||
` stwu 0, -{emit_int trap_frame_size}(1)\n`;
|
||||
` stw 29, 4(1)\n`;
|
||||
if toc then
|
||||
` stw 2, 20(1)\n`;
|
||||
` mr 29, 1\n`
|
||||
| Lpoptrap ->
|
||||
` lwz 29, 4(1)\n`;
|
||||
` addi 1, 1, {emit_int trap_frame_size}\n`;
|
||||
stack_offset := !stack_offset - trap_frame_size
|
||||
| Lraise ->
|
||||
` lwz 0, 0(29)\n`;
|
||||
` mr 1, 29\n`;
|
||||
` mtlr 0\n`;
|
||||
` lwz 29, 4(1)\n`;
|
||||
if toc then
|
||||
` lwz 2, 20(1)\n`;
|
||||
` addi 1, 1, {emit_int trap_frame_size}\n\n`;
|
||||
` blr\n`
|
||||
|
||||
and emit_delay = function
|
||||
None -> ()
|
||||
| Some i -> emit_instr i None
|
||||
|
||||
(* Checks if a pseudo-instruction expands to instructions
|
||||
that do not branch and do not affect CR0 nor R12. *)
|
||||
|
||||
let is_simple_instr i =
|
||||
match i.desc with
|
||||
Lop op ->
|
||||
begin match op with
|
||||
Icall_imm _ | Icall_ind | Itailcall_imm _ | Itailcall_ind |
|
||||
Iextcall(_, _) -> false
|
||||
| Ialloc(_) -> false
|
||||
| Iintop(Icomp _) -> false
|
||||
| Iintop_imm(Iand, _) -> false
|
||||
| Iintop_imm(Icomp _, _) -> false
|
||||
| _ -> true
|
||||
end
|
||||
| Lreloadretaddr -> true
|
||||
| _ -> false
|
||||
|
||||
let no_interference res arg =
|
||||
try
|
||||
for i = 0 to Array.length arg - 1 do
|
||||
for j = 0 to Array.length res - 1 do
|
||||
if arg.(i).loc = res.(j).loc then raise Exit
|
||||
done
|
||||
done;
|
||||
true
|
||||
with Exit ->
|
||||
false
|
||||
|
||||
(* Emit a sequence of instructions, trying to fill delay slots for branches *)
|
||||
|
||||
let rec emit_all i =
|
||||
match i with
|
||||
{desc = Lend} -> ()
|
||||
| {next = {desc = (Lcondbranch(_, _) | Lcondbranch3(_, _, _))}}
|
||||
when is_simple_instr i & no_interference i.res i.next.arg ->
|
||||
emit_instr i.next (Some i);
|
||||
emit_all i.next.next
|
||||
| _ ->
|
||||
emit_instr i None;
|
||||
emit_all i.next
|
||||
|
||||
(* Emission of a function declaration *)
|
||||
|
||||
let fundecl fundecl =
|
||||
function_name := fundecl.fun_name;
|
||||
defined_functions := StringSet.add fundecl.fun_name !defined_functions;
|
||||
tailrec_entry_point := new_label();
|
||||
stack_offset := 0;
|
||||
call_gc_label := 0;
|
||||
float_literals := [];
|
||||
` .globl {emit_symbol fundecl.fun_name}\n`;
|
||||
if toc then begin
|
||||
` .globl .{emit_symbol fundecl.fun_name}\n`;
|
||||
` .csect {emit_symbol fundecl.fun_name}[DS]\n`;
|
||||
`{emit_symbol fundecl.fun_name}:\n`;
|
||||
` .long .{emit_symbol fundecl.fun_name}, TOC[tc0], 0\n`
|
||||
end else begin
|
||||
` .type {emit_symbol fundecl.fun_name}, @function\n`
|
||||
end;
|
||||
emit_string code_space;
|
||||
` .align 2\n`;
|
||||
`{emit_codesymbol fundecl.fun_name}:\n`;
|
||||
let n = frame_size() in
|
||||
if !contains_calls then begin
|
||||
` mflr 0\n`;
|
||||
` addi 1, 1, {emit_int(-n)}\n`;
|
||||
` stw 0, {emit_int(n - 4)}(1)\n`
|
||||
end else
|
||||
` addi 1, 1, {emit_int(-n)}\n`;
|
||||
`{emit_label !tailrec_entry_point}:\n`;
|
||||
emit_all fundecl.fun_body;
|
||||
(* Emit the glue code to call the GC *)
|
||||
if !call_gc_label > 0 then begin
|
||||
`{emit_label !call_gc_label}:\n`;
|
||||
if toc then begin
|
||||
` mflr 0\n`; (* Save return address in r0 *)
|
||||
` bl .caml_call_gc\n`;
|
||||
` cror 31, 31, 31\n`; (* nop *)
|
||||
` blr\n` (* Will re-execute the allocation *)
|
||||
end else begin
|
||||
` b caml_call_gc\n`
|
||||
end
|
||||
end;
|
||||
(* Emit the floating-point literals *)
|
||||
if !float_literals <> [] then begin
|
||||
` .section \".rodata\"\n`;
|
||||
` .align 3\n`;
|
||||
List.iter
|
||||
(fun (f, lbl) ->
|
||||
`{emit_label lbl}: .double 0d{emit_string f}\n`)
|
||||
!float_literals
|
||||
end
|
||||
|
||||
(* Emission of data *)
|
||||
|
||||
let declare_global_data s =
|
||||
` .globl {emit_symbol s}\n`;
|
||||
if not toc then ` .type {emit_symbol s}, @object\n`
|
||||
|
||||
let emit_item = function
|
||||
Cdefine_symbol s ->
|
||||
`{emit_symbol s}:\n`;
|
||||
declare_global_data s
|
||||
| Cdefine_label lbl ->
|
||||
`{emit_label (lbl + 10000)}:\n`
|
||||
| Cint8 n ->
|
||||
` .byte {emit_int n}\n`
|
||||
| Cint16 n ->
|
||||
` .short {emit_int n}\n`
|
||||
| Cint n ->
|
||||
` .long {emit_nativeint n}\n`
|
||||
| Cfloat f ->
|
||||
` .double 0d{emit_string f}\n`
|
||||
| Csymbol_address s ->
|
||||
` .long {emit_symbol s}\n`
|
||||
| Clabel_address lbl ->
|
||||
` .long {emit_label (lbl + 10000)}\n`
|
||||
| Cstring s ->
|
||||
emit_bytes_directive " .byte " s
|
||||
| Cskip n ->
|
||||
if n > 0 then ` .space {emit_int n}\n`
|
||||
| Calign n ->
|
||||
` .align {emit_int (Misc.log2 n)}\n`
|
||||
|
||||
let data l =
|
||||
emit_string data_space;
|
||||
List.iter emit_item l
|
||||
|
||||
(* Beginning / end of an assembly file *)
|
||||
|
||||
let begin_assembly() =
|
||||
Hashtbl.clear symbol_constants;
|
||||
Hashtbl.clear float_constants;
|
||||
defined_functions := StringSet.empty;
|
||||
num_jumptbl_entries := 0;
|
||||
jumptbl_entries := [];
|
||||
lbl_jumptbl := 0;
|
||||
(* Emit the beginning of the segments *)
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
|
||||
emit_string data_space;
|
||||
declare_global_data lbl_begin;
|
||||
`{emit_symbol lbl_begin}:\n`;
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
|
||||
emit_string code_space;
|
||||
declare_global_data lbl_begin;
|
||||
`{emit_symbol lbl_begin}:\n`
|
||||
|
||||
let end_assembly() =
|
||||
(* Emit the jump table *)
|
||||
if !num_jumptbl_entries > 0 then begin
|
||||
let lbl_tbl =
|
||||
if toc then begin
|
||||
let lbl_tbl = new_label() in
|
||||
` .toc\n`;
|
||||
`{emit_label !lbl_jumptbl}: .tc {emit_label lbl_tbl}[TC], {emit_label lbl_tbl}\n`;
|
||||
` .csect .text[PR]\n`;
|
||||
lbl_tbl
|
||||
end else begin
|
||||
` .section \".text\"\n`;
|
||||
!lbl_jumptbl
|
||||
end in
|
||||
`{emit_label lbl_tbl}:\n`;
|
||||
List.iter
|
||||
(fun lbl -> ` .long {emit_label lbl} - {emit_label lbl_tbl}\n`)
|
||||
(List.rev !jumptbl_entries);
|
||||
jumptbl_entries := []
|
||||
end;
|
||||
if toc then begin
|
||||
(* Emit the table of constants *)
|
||||
` .toc\n`;
|
||||
Hashtbl.iter emit_symbol_constant symbol_constants;
|
||||
Hashtbl.iter emit_float_constant float_constants
|
||||
end;
|
||||
(* Emit the end of the segments *)
|
||||
emit_string code_space;
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
|
||||
declare_global_data lbl_end;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
emit_string data_space;
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
|
||||
declare_global_data lbl_end;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
` .long 0\n`;
|
||||
(* Emit the frame descriptors *)
|
||||
let lbl = Compilenv.current_unit_name() ^ "_frametable" in
|
||||
declare_global_data lbl;
|
||||
`{emit_symbol lbl}:\n`;
|
||||
` .long {emit_int (List.length !frame_descriptors)}\n`;
|
||||
List.iter emit_frame !frame_descriptors;
|
||||
frame_descriptors := []
|
||||
|
|
@ -1,684 +0,0 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* 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
|
||||
|
||||
(* Layout of the stack *)
|
||||
(* Always keep the stack 8-aligned.
|
||||
Always leave 96 bytes at the bottom of the stack *)
|
||||
|
||||
let stack_offset = ref 0
|
||||
|
||||
let frame_size () =
|
||||
let size =
|
||||
!stack_offset +
|
||||
4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) +
|
||||
(if !contains_calls then 4 else 0) in
|
||||
Misc.align size 8
|
||||
|
||||
let slot_offset loc cl =
|
||||
match loc with
|
||||
Incoming n -> frame_size() + n + 96
|
||||
| Local n ->
|
||||
if cl = 0
|
||||
then !stack_offset + num_stack_slots.(1) * 8 + n * 4 + 96
|
||||
else !stack_offset + n * 8 + 96
|
||||
| Outgoing n -> n + 96
|
||||
|
||||
(* 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"
|
||||
|
||||
(* Symbols are prefixed with _ under SunOS and BSD but not under Solaris *)
|
||||
|
||||
let symbol_prefix =
|
||||
if Config.system = "solaris" then "" else "_"
|
||||
|
||||
let emit_symbol s =
|
||||
if String.length s >= 1 & s.[0] = '.'
|
||||
then emit_string s
|
||||
else begin emit_string symbol_prefix; Emitaux.emit_symbol '$' s end
|
||||
|
||||
(* Check if a native integer is an immediate operand *)
|
||||
|
||||
let is_native_immediate n =
|
||||
Nativeint.cmp n 4095 <= 0 && Nativeint.cmp n (-4096) >= 0
|
||||
|
||||
(* Output a label *)
|
||||
|
||||
let label_prefix =
|
||||
if Config.system = "solaris" then ".L" else "L"
|
||||
|
||||
let emit_label lbl =
|
||||
emit_string label_prefix; 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 := ((r lsl 1) + 1) :: !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 =
|
||||
` .word {emit_label fd.fd_lbl}\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 4\n`
|
||||
|
||||
(* Record floating-point constants *)
|
||||
|
||||
let float_constants = ref ([] : (int * string) list)
|
||||
|
||||
let emit_float_constant (lbl, cst) =
|
||||
` .data\n`;
|
||||
` .align 8\n`;
|
||||
`{emit_label lbl}: .double 0r{emit_string cst}\n`
|
||||
|
||||
(* Names of various instructions *)
|
||||
|
||||
let name_for_int_operation = function
|
||||
Iadd -> "add"
|
||||
| Isub -> "sub"
|
||||
| Iand -> "and"
|
||||
| Ior -> "or"
|
||||
| Ixor -> "xor"
|
||||
| Ilsl -> "sll"
|
||||
| Ilsr -> "srl"
|
||||
| Iasr -> "sra"
|
||||
| _ -> Misc.fatal_error "Emit.name_for_int_operation"
|
||||
|
||||
let name_for_float_operation = function
|
||||
Inegf -> "fnegs"
|
||||
| Iabsf -> "fabss"
|
||||
| Iaddf -> "faddd"
|
||||
| Isubf -> "fsubd"
|
||||
| Imulf -> "fmuld"
|
||||
| Idivf -> "fdivd"
|
||||
| _ -> Misc.fatal_error "Emit.name_for_float_operation"
|
||||
|
||||
let name_for_int_comparison = function
|
||||
Isigned Ceq -> "be" | Isigned Cne -> "bne"
|
||||
| Isigned Cle -> "ble" | Isigned Cgt -> "bg"
|
||||
| Isigned Clt -> "bl" | Isigned Cge -> "bge"
|
||||
| Iunsigned Ceq -> "be" | Iunsigned Cne -> "bne"
|
||||
| Iunsigned Cle -> "bleu" | Iunsigned Cgt -> "bgu"
|
||||
| Iunsigned Clt -> "blu" | Iunsigned Cge -> "bgeu"
|
||||
|
||||
let name_for_float_comparison cmp neg =
|
||||
match cmp with
|
||||
Ceq -> if neg then "fbne" else "fbe"
|
||||
| Cne -> if neg then "fbe" else "fbne"
|
||||
| Cle -> if neg then "fbug" else "fble"
|
||||
| Cgt -> if neg then "fbule" else "fbg"
|
||||
| Clt -> if neg then "fbuge" else "fbl"
|
||||
| Cge -> if neg then "fbul" else "fbge"
|
||||
|
||||
(* Output the assembly code for an instruction *)
|
||||
|
||||
let function_name = ref ""
|
||||
let tailrec_entry_point = ref 0
|
||||
|
||||
let rec emit_instr i dslot =
|
||||
match i.desc with
|
||||
Lend -> ()
|
||||
| Lop(Imove | Ispill | Ireload) ->
|
||||
let src = i.arg.(0) and dst = i.res.(0) in
|
||||
begin match (src, dst) with
|
||||
{loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} ->
|
||||
` mov {emit_reg src}, {emit_reg dst}\n`
|
||||
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
|
||||
` fmovd {emit_reg src}, {emit_reg dst}\n`
|
||||
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = (Int | Addr)} ->
|
||||
(* This happens when calling C functions and passing a float arg
|
||||
in %o0...%o5 *)
|
||||
` sub %sp, 8, %sp\n`;
|
||||
` std {emit_reg src}, [%sp + 96]\n`;
|
||||
if rd land 1 = 0 then
|
||||
` ldd [%sp + 96], {emit_reg dst}\n`
|
||||
else begin
|
||||
` ld [%sp + 96], {emit_reg dst}\n`;
|
||||
` ld [%sp + 100], {emit_reg(next_in_pair dst)}\n`
|
||||
end;
|
||||
` add %sp, 8, %sp\n`
|
||||
| {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} ->
|
||||
` st {emit_reg src}, {emit_stack dst}\n`
|
||||
| {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
|
||||
` std {emit_reg src}, {emit_stack dst}\n`
|
||||
| {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} ->
|
||||
` ld {emit_stack src}, {emit_reg dst}\n`
|
||||
| {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
|
||||
` ldd {emit_stack src}, {emit_reg dst}\n`
|
||||
| (_, _) ->
|
||||
fatal_error "Emit: Imove"
|
||||
end
|
||||
| Lop(Iconst_int n) ->
|
||||
if is_native_immediate n then
|
||||
` mov {emit_nativeint n}, {emit_reg i.res.(0)}\n`
|
||||
else begin
|
||||
` sethi %hi({emit_nativeint n}), %g1\n`;
|
||||
` or %g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n`
|
||||
end
|
||||
| Lop(Iconst_float s) ->
|
||||
let lbl = new_label() in
|
||||
float_constants := (lbl, s) :: !float_constants;
|
||||
` sethi %hi({emit_label lbl}), %g1\n`;
|
||||
` ldd [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n`
|
||||
| Lop(Iconst_symbol s) ->
|
||||
` sethi %hi({emit_symbol s}), %g1\n`;
|
||||
` or %g1, %lo({emit_symbol s}), {emit_reg i.res.(0)}\n`
|
||||
| Lop(Icall_ind) ->
|
||||
`{record_frame i.live} call {emit_reg i.arg.(0)}\n`;
|
||||
fill_delay_slot dslot
|
||||
| Lop(Icall_imm s) ->
|
||||
`{record_frame i.live} call {emit_symbol s}\n`;
|
||||
fill_delay_slot dslot
|
||||
| Lop(Itailcall_ind) ->
|
||||
let n = frame_size() in
|
||||
if !contains_calls then
|
||||
` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`;
|
||||
` jmp {emit_reg i.arg.(0)}\n`;
|
||||
` add %sp, {emit_int n}, %sp\n` (* in delay slot *)
|
||||
| Lop(Itailcall_imm s) ->
|
||||
let n = frame_size() in
|
||||
if s = !function_name then begin
|
||||
` b {emit_label !tailrec_entry_point}\n`;
|
||||
fill_delay_slot dslot
|
||||
end else begin
|
||||
if !contains_calls then
|
||||
` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`;
|
||||
` sethi %hi({emit_symbol s}), %g1\n`;
|
||||
` jmp %g1 + %lo({emit_symbol s})\n`;
|
||||
` add %sp, {emit_int n}, %sp\n` (* in delay slot *)
|
||||
end
|
||||
| Lop(Iextcall(s, alloc)) ->
|
||||
if alloc then begin
|
||||
` sethi %hi({emit_symbol s}), %g2\n`;
|
||||
`{record_frame i.live} call {emit_symbol "caml_c_call"}\n`;
|
||||
` or %g2, %lo({emit_symbol s}), %g2\n` (* in delay slot *)
|
||||
end else begin
|
||||
` call {emit_symbol s}\n`;
|
||||
fill_delay_slot dslot
|
||||
end
|
||||
| Lop(Istackoffset n) ->
|
||||
` add %sp, {emit_int (-n)}, %sp\n`;
|
||||
stack_offset := !stack_offset + n
|
||||
| Lop(Iload(chunk, addr)) ->
|
||||
begin match i.res.(0).typ with
|
||||
Int | Addr ->
|
||||
let loadinstr =
|
||||
match chunk with
|
||||
Word -> "ld"
|
||||
| Byte_unsigned -> "ldub"
|
||||
| Byte_signed -> "ldsb"
|
||||
| Sixteen_unsigned -> "lduh"
|
||||
| Sixteen_signed -> "ldsh" in
|
||||
emit_load loadinstr addr i.arg i.res.(0)
|
||||
| Float ->
|
||||
emit_load "ld" addr i.arg i.res.(0);
|
||||
emit_load "ld" (offset_addressing addr 4) i.arg (next_in_pair i.res.(0))
|
||||
end
|
||||
| Lop(Istore(chunk, addr)) ->
|
||||
begin match i.arg.(0).typ with
|
||||
Int | Addr ->
|
||||
let storeinstr =
|
||||
match chunk with
|
||||
Word -> "st"
|
||||
| Byte_unsigned | Byte_signed -> "stb"
|
||||
| Sixteen_unsigned | Sixteen_signed -> "sth" in
|
||||
emit_store storeinstr addr i.arg i.arg.(0)
|
||||
| Float ->
|
||||
emit_store "st" addr i.arg i.arg.(0);
|
||||
emit_store "st" (offset_addressing addr 4) i.arg (next_in_pair i.arg.(0))
|
||||
end
|
||||
| Lop(Ialloc n) ->
|
||||
if !fastcode_flag then begin
|
||||
let lbl_cont = new_label() in
|
||||
` ld [%l7], %g1\n`;
|
||||
` sub %l6, {emit_int n}, %l6\n`;
|
||||
` cmp %l6, %g1\n`;
|
||||
` bgeu {emit_label lbl_cont}\n`;
|
||||
` add %l6, 4, {emit_reg i.res.(0)}\n`; (* in delay slot *)
|
||||
`{record_frame i.live} call {emit_symbol "caml_call_gc"}\n`;
|
||||
` mov {emit_int n}, %g2\n`; (* in delay slot *)
|
||||
` add %l6, 4, {emit_reg i.res.(0)}\n`;
|
||||
`{emit_label lbl_cont}:\n`
|
||||
end else begin
|
||||
`{record_frame i.live} call {emit_symbol "caml_alloc"}\n`;
|
||||
` mov {emit_int n}, %g2\n`; (* in delay slot *)
|
||||
` add %l6, 4, {emit_reg i.res.(0)}\n`
|
||||
end
|
||||
| Lop(Iintop(Icomp cmp)) ->
|
||||
let comp = name_for_int_comparison cmp in
|
||||
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
let lbl = new_label() in
|
||||
` {emit_string comp},a {emit_label lbl}\n`;
|
||||
` mov 1, {emit_reg i.res.(0)}\n`;
|
||||
` mov 0, {emit_reg i.res.(0)}\n`;
|
||||
`{emit_label lbl}:\n`
|
||||
| Lop(Iintop Icheckbound) ->
|
||||
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
` tleu 5\n` (* 5 = ST_RANGE_CHECK *)
|
||||
| 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(Idiv, n)) -> (* n is a power of 2 *)
|
||||
let l = Misc.log2 n in
|
||||
let lbl = new_label() in
|
||||
` cmp {emit_reg i.arg.(0)}, 0\n`;
|
||||
` bge {emit_label lbl}\n`;
|
||||
` mov {emit_reg i.arg.(0)}, %g1\n`; (* in delay slot *)
|
||||
` add %g1, {emit_int (n-1)}, %g1\n`;
|
||||
`{emit_label lbl}:\n`;
|
||||
` sra %g1, {emit_int l}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *)
|
||||
let lbl = new_label() in
|
||||
` tst {emit_reg i.arg.(0)}\n`;
|
||||
` bge {emit_label lbl}\n`;
|
||||
` andcc {emit_reg i.arg.(0)}, {emit_int (n-1)}, {emit_reg i.res.(0)}\n`; (* in delay slot *)
|
||||
` be {emit_label lbl}\n`;
|
||||
` nop\n`;
|
||||
` sub {emit_reg i.res.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`;
|
||||
`{emit_label lbl}:\n`
|
||||
| Lop(Iintop_imm(Icomp cmp, n)) ->
|
||||
let comp = name_for_int_comparison cmp in
|
||||
` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`;
|
||||
let lbl = new_label() in
|
||||
` {emit_string comp},a {emit_label lbl}\n`;
|
||||
` mov 1, {emit_reg i.res.(0)}\n`;
|
||||
` mov 0, {emit_reg i.res.(0)}\n`;
|
||||
`{emit_label lbl}:\n`
|
||||
| Lop(Iintop_imm(Icheckbound, n)) ->
|
||||
` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`;
|
||||
` tleu 5\n` (* 5 = ST_RANGE_CHECK *)
|
||||
| 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(Inegf | Iabsf as op) ->
|
||||
let instr = name_for_float_operation op in
|
||||
` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`;
|
||||
` fmovs {emit_reg(next_in_pair i.arg.(0))}, {emit_reg(next_in_pair i.res.(0))}\n`
|
||||
| Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
|
||||
let instr = name_for_float_operation op in
|
||||
` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Ifloatofint) ->
|
||||
` sub %sp, 8, %sp\n`;
|
||||
` st {emit_reg i.arg.(0)}, [%sp + 96]\n`;
|
||||
` ld [%sp + 96], %f30\n`;
|
||||
` add %sp, 8, %sp\n`;
|
||||
` fitod %f30, {emit_reg i.res.(0)}\n`
|
||||
| Lop(Iintoffloat) ->
|
||||
` fdtoi {emit_reg i.arg.(0)}, %f30\n`;
|
||||
` sub %sp, 8, %sp\n`;
|
||||
` st %f30, [%sp + 96]\n`;
|
||||
` ld [%sp + 96], {emit_reg i.res.(0)}\n`;
|
||||
` add %sp, 8, %sp\n`
|
||||
| Lop(Ispecific sop) ->
|
||||
fatal_error "Emit: specific"
|
||||
| Lreloadretaddr ->
|
||||
let n = frame_size() in
|
||||
` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`
|
||||
| Lreturn ->
|
||||
let n = frame_size() in
|
||||
` retl\n`;
|
||||
` add %sp, {emit_int n}, %sp\n`
|
||||
| Llabel lbl ->
|
||||
`{emit_label lbl}:\n`
|
||||
| Lbranch lbl ->
|
||||
` b {emit_label lbl}\n`;
|
||||
fill_delay_slot dslot
|
||||
| Lcondbranch(tst, lbl) ->
|
||||
begin match tst with
|
||||
Itruetest ->
|
||||
` tst {emit_reg i.arg.(0)}\n`;
|
||||
` bne {emit_label lbl}\n`
|
||||
| Ifalsetest ->
|
||||
` tst {emit_reg i.arg.(0)}\n`;
|
||||
` be {emit_label lbl}\n`
|
||||
| Iinttest cmp ->
|
||||
let comp = name_for_int_comparison cmp in
|
||||
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
` {emit_string comp} {emit_label lbl}\n`
|
||||
| Iinttest_imm(cmp, n) ->
|
||||
let comp = name_for_int_comparison cmp in
|
||||
` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`;
|
||||
` {emit_string comp} {emit_label lbl}\n`
|
||||
| Ifloattest(cmp, neg) ->
|
||||
let comp = name_for_float_comparison cmp neg in
|
||||
` fcmpd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
` nop\n`;
|
||||
` {emit_string comp} {emit_label lbl}\n`
|
||||
| Ioddtest ->
|
||||
` andcc {emit_reg i.arg.(0)}, 1, %g0\n`;
|
||||
` bne {emit_label lbl}\n`
|
||||
| Ieventest ->
|
||||
` andcc {emit_reg i.arg.(0)}, 1, %g0\n`;
|
||||
` be {emit_label lbl}\n`
|
||||
end;
|
||||
fill_delay_slot dslot
|
||||
| Lcondbranch3(lbl0, lbl1, lbl2) ->
|
||||
` cmp {emit_reg i.arg.(0)}, 1\n`;
|
||||
begin match lbl0 with
|
||||
None -> ()
|
||||
| Some lbl -> ` bl {emit_label lbl}\n nop\n`
|
||||
end;
|
||||
begin match lbl1 with
|
||||
None -> ()
|
||||
| Some lbl -> ` be {emit_label lbl}\n nop\n`
|
||||
end;
|
||||
begin match lbl2 with
|
||||
None -> ()
|
||||
| Some lbl -> ` bg {emit_label lbl}\n nop\n`
|
||||
end
|
||||
| Lswitch jumptbl ->
|
||||
let lbl_jumptbl = new_label() in
|
||||
` sethi %hi({emit_label lbl_jumptbl}), %g1\n`;
|
||||
` or %g1, %lo({emit_label lbl_jumptbl}), %g1\n`;
|
||||
` sll {emit_reg i.arg.(0)}, 2, %g2\n`;
|
||||
` ld [%g1 + %g2], %g1\n`;
|
||||
` jmp %g1\n`; (* poor scheduling *)
|
||||
` nop\n`;
|
||||
`{emit_label lbl_jumptbl}:`;
|
||||
for i = 0 to Array.length jumptbl - 1 do
|
||||
` .word {emit_label jumptbl.(i)}\n`
|
||||
done
|
||||
| Lsetuptrap lbl ->
|
||||
` call {emit_label lbl}\n`;
|
||||
` sub %sp, 8, %sp\n` (* in delay slot *)
|
||||
| Lpushtrap ->
|
||||
stack_offset := !stack_offset + 8;
|
||||
` st %o7, [%sp + 96]\n`;
|
||||
` st %l5, [%sp + 100]\n`;
|
||||
` mov %sp, %l5\n`
|
||||
| Lpoptrap ->
|
||||
` ld [%sp + 100], %l5\n`;
|
||||
` add %sp, 8, %sp\n`;
|
||||
stack_offset := !stack_offset - 8
|
||||
| Lraise ->
|
||||
` ld [%l5 + 96], %g1\n`;
|
||||
` mov %l5, %sp\n`;
|
||||
` ld [%sp + 100], %l5\n`;
|
||||
` jmp %g1 + 8\n`;
|
||||
` add %sp, 8, %sp\n`
|
||||
|
||||
and fill_delay_slot = function
|
||||
None -> ` nop\n`
|
||||
| Some i -> emit_instr i None
|
||||
|
||||
(* Checks if a pseudo-instruction expands to exactly one machine instruction
|
||||
that does not branch. *)
|
||||
|
||||
let is_one_instr_op = function
|
||||
Idiv | Imod | Icomp _ | Icheckbound -> false
|
||||
| _ -> true
|
||||
|
||||
let is_one_instr i =
|
||||
match i.desc with
|
||||
Lop op ->
|
||||
begin match op with
|
||||
Imove | Ispill | Ireload -> i.arg.(0).typ = i.res.(0).typ
|
||||
| Iconst_int n -> is_native_immediate n
|
||||
| Istackoffset _ -> true
|
||||
| Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_immediate n
|
||||
| Iload(_, Iindexed2 n) -> i.res.(0).typ <> Float & n = 0
|
||||
| Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_immediate n
|
||||
| Istore(_, Iindexed2 n) -> i.arg.(0).typ <> Float & n = 0
|
||||
| Iintop(op) -> is_one_instr_op op
|
||||
| Iintop_imm(op, _) -> is_one_instr_op op
|
||||
| Iaddf | Isubf | Imulf | Idivf -> true
|
||||
| _ -> false
|
||||
end
|
||||
| _ -> false
|
||||
|
||||
let no_interference res arg =
|
||||
try
|
||||
for i = 0 to Array.length arg - 1 do
|
||||
for j = 0 to Array.length res - 1 do
|
||||
if arg.(i).loc = res.(j).loc then raise Exit
|
||||
done
|
||||
done;
|
||||
true
|
||||
with Exit ->
|
||||
false
|
||||
|
||||
(* Emit a sequence of instructions, trying to fill delay slots for branches *)
|
||||
|
||||
let rec emit_all i =
|
||||
match i with
|
||||
{desc = Lend} -> ()
|
||||
| {next = {desc = Lop(Icall_imm _) | Lop(Iextcall(_, false)) | Lbranch _}}
|
||||
when is_one_instr i ->
|
||||
emit_instr i.next (Some i);
|
||||
emit_all i.next.next
|
||||
| {next = {desc = Lop(Itailcall_imm s)}}
|
||||
when s = !function_name & is_one_instr i ->
|
||||
emit_instr i.next (Some i);
|
||||
emit_all i.next.next
|
||||
| {next = {desc = Lop(Icall_ind)}}
|
||||
when is_one_instr i & no_interference i.res i.next.arg ->
|
||||
emit_instr i.next (Some i);
|
||||
emit_all i.next.next
|
||||
| {next = {desc = Lcondbranch(_, _)}}
|
||||
when is_one_instr i & no_interference i.res i.next.arg ->
|
||||
emit_instr i.next (Some i);
|
||||
emit_all i.next.next
|
||||
| _ ->
|
||||
emit_instr i None;
|
||||
emit_all i.next
|
||||
|
||||
(* Emission of a function declaration *)
|
||||
|
||||
let fundecl fundecl =
|
||||
function_name := fundecl.fun_name;
|
||||
fastcode_flag := fundecl.fun_fast;
|
||||
tailrec_entry_point := new_label();
|
||||
stack_offset := 0;
|
||||
float_constants := [];
|
||||
` .text\n`;
|
||||
` .align 4\n`;
|
||||
` .global {emit_symbol fundecl.fun_name}\n`;
|
||||
`{emit_symbol fundecl.fun_name}:\n`;
|
||||
let n = frame_size() in
|
||||
if n > 0 then
|
||||
` sub %sp, {emit_int n}, %sp\n`;
|
||||
if !contains_calls then
|
||||
` st %o7, [%sp + {emit_int(n - 4 + 96)}]\n`;
|
||||
`{emit_label !tailrec_entry_point}:\n`;
|
||||
emit_all fundecl.fun_body;
|
||||
List.iter emit_float_constant !float_constants
|
||||
|
||||
(* Emission of data *)
|
||||
|
||||
let emit_item = function
|
||||
Cdefine_symbol s ->
|
||||
` .global {emit_symbol s}\n`;
|
||||
`{emit_symbol s}:\n`
|
||||
| Cdefine_label lbl ->
|
||||
`{emit_label (lbl + 10000)}:\n`
|
||||
| Cint8 n ->
|
||||
` .byte {emit_int n}\n`
|
||||
| Cint16 n ->
|
||||
` .half {emit_int n}\n`
|
||||
| Cint n ->
|
||||
` .word {emit_nativeint n}\n`
|
||||
| Cfloat f ->
|
||||
` .double 0r{emit_string f}\n`
|
||||
| Csymbol_address s ->
|
||||
` .word {emit_symbol s}\n`
|
||||
| Clabel_address lbl ->
|
||||
` .word {emit_label (lbl + 10000)}\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 ` .skip {emit_int n}\n`
|
||||
| Calign n ->
|
||||
` .align {emit_int n}\n`
|
||||
|
||||
let data l =
|
||||
` .data\n`;
|
||||
List.iter emit_item l
|
||||
|
||||
(* Beginning / end of an assembly file *)
|
||||
|
||||
let begin_assembly() =
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
|
||||
` .data\n`;
|
||||
` .global {emit_symbol lbl_begin}\n`;
|
||||
`{emit_symbol lbl_begin}:\n`;
|
||||
let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
|
||||
` .text\n`;
|
||||
` .global {emit_symbol lbl_begin}\n`;
|
||||
`{emit_symbol lbl_begin}:\n`
|
||||
|
||||
let end_assembly() =
|
||||
` .text\n`;
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
|
||||
` .global {emit_symbol lbl_end}\n`;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
` .data\n`;
|
||||
let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
|
||||
` .global {emit_symbol lbl_end}\n`;
|
||||
`{emit_symbol lbl_end}:\n`;
|
||||
` .word 0\n`;
|
||||
let lbl = Compilenv.current_unit_name() ^ "_frametable" in
|
||||
` .global {emit_symbol lbl}\n`;
|
||||
`{emit_symbol lbl}:\n`;
|
||||
` .word {emit_int (List.length !frame_descriptors)}\n`;
|
||||
List.iter emit_frame !frame_descriptors;
|
||||
frame_descriptors := []
|
||||
|
|
@ -11,7 +11,7 @@
|
|||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Description of the HP PA-RICS processor *)
|
||||
(* Description of the HP PA-RISC processor *)
|
||||
|
||||
open Misc
|
||||
open Cmm
|
||||
|
|
@ -93,90 +93,8 @@ let phys_reg n =
|
|||
let stack_slot slot ty =
|
||||
Reg.at_location ty (Stack slot)
|
||||
|
||||
(* Exceptions raised to signal cases not handled here *)
|
||||
|
||||
exception Use_default
|
||||
|
||||
(* Recognition of addressing modes *)
|
||||
|
||||
let select_addressing = function
|
||||
Cconst_symbol s ->
|
||||
(Ibased(s, 0), Ctuple [])
|
||||
| Cop(Cadda, [Cconst_symbol s; Cconst_int n]) ->
|
||||
(Ibased(s, n), Ctuple [])
|
||||
| Cop(Cadda, [arg; Cconst_int n]) ->
|
||||
(Iindexed n, arg)
|
||||
| Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) ->
|
||||
(Iindexed n, Cop(Cadda, [arg1; arg2]))
|
||||
| arg ->
|
||||
(Iindexed 0, arg)
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
let shiftadd = function
|
||||
2 -> Ishift1add
|
||||
| 4 -> Ishift2add
|
||||
| 8 -> Ishift3add
|
||||
| _ -> fatal_error "Proc_hppa.shiftadd"
|
||||
|
||||
let select_oper op args =
|
||||
match (op, args) with
|
||||
(* Recognize shift-add operations. *)
|
||||
((Caddi|Cadda),
|
||||
[arg2; Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)])]) ->
|
||||
(Ispecific(shiftadd(1 lsl shift)), [arg1; arg2])
|
||||
| ((Caddi|Cadda),
|
||||
[arg2; Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)])]) ->
|
||||
(Ispecific(shiftadd mult), [arg1; arg2])
|
||||
| ((Caddi|Cadda),
|
||||
[arg2; Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1])]) ->
|
||||
(Ispecific(shiftadd mult), [arg1; arg2])
|
||||
| (Caddi, [Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)]); arg2]) ->
|
||||
(Ispecific(shiftadd(1 lsl shift)), [arg1; arg2])
|
||||
| (Caddi, [Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)]); arg2]) ->
|
||||
(Ispecific(shiftadd mult), [arg1; arg2])
|
||||
| (Caddi, [Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1]); arg2]) ->
|
||||
(Ispecific(shiftadd mult), [arg1; arg2])
|
||||
(* Prevent the recognition of some immediate arithmetic operations *)
|
||||
(* Cmuli : -> Ilsl if power of 2
|
||||
Cdivi, Cmodi : only if power of 2
|
||||
Cand, Cor, Cxor : never *)
|
||||
| (Cmuli, ([arg1; Cconst_int n] as args)) ->
|
||||
let l = Misc.log2 n in
|
||||
if n = 1 lsl l
|
||||
then (Iintop_imm(Ilsl, l), [arg1])
|
||||
else (Iintop Imul, args)
|
||||
| (Cmuli, ([Cconst_int n; arg1] as args)) ->
|
||||
let l = Misc.log2 n in
|
||||
if n = 1 lsl l
|
||||
then (Iintop_imm(Ilsl, l), [arg1])
|
||||
else (Iintop Imul, args)
|
||||
| (Cmuli, args) -> (Iintop Imul, args)
|
||||
| (Cdivi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Idiv, n), [arg1])
|
||||
| (Cdivi, args) -> (Iintop Idiv, args)
|
||||
| (Cmodi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Imod, n), [arg1])
|
||||
| (Cmodi, args) -> (Iintop Imod, args)
|
||||
| (Cand, args) -> (Iintop Iand, args)
|
||||
| (Cor, args) -> (Iintop Ior, args)
|
||||
| (Cxor, args) -> (Iintop Ixor, args)
|
||||
| _ -> raise Use_default
|
||||
|
||||
let select_store addr exp = raise Use_default
|
||||
|
||||
let select_push exp = fatal_error "Proc: select_push"
|
||||
|
||||
let pseudoregs_for_operation op arg res =
|
||||
match op with
|
||||
Iintop(Idiv | Imod) -> (* handled via calls to millicode *)
|
||||
([|phys_reg 20; phys_reg 19|], [|phys_reg 22|], true)
|
||||
(* %r26, %r25, %r29 *)
|
||||
| _ ->
|
||||
raise Use_default
|
||||
|
||||
let is_immediate n = (n < 16) & (n >= -16) (* 5 bits *)
|
||||
|
||||
let word_addressed = false
|
||||
|
||||
(* Calling conventions *)
|
||||
|
|
@ -252,8 +170,6 @@ let loc_external_arguments arg =
|
|||
done;
|
||||
(loc, Misc.align !ofs 8)
|
||||
|
||||
let extcall_use_push = false
|
||||
|
||||
let loc_external_results res =
|
||||
let (loc, ofs) = calling_conventions 21 21 100 100 not_supported res in loc
|
||||
|
||||
|
|
@ -292,24 +208,6 @@ let max_register_pressure = function
|
|||
| Iintop(Idiv | Imod) -> [| 19; 27 |]
|
||||
| _ -> [| 23; 27 |]
|
||||
|
||||
(* Reloading *)
|
||||
|
||||
let reload_test makereg round tst args = raise Use_default
|
||||
let reload_operation makereg round op args res = raise Use_default
|
||||
|
||||
(* Latencies (in cycles). Roughly based on the ``Mustang'' chips. *)
|
||||
|
||||
let need_scheduling = true
|
||||
|
||||
let oper_latency = function
|
||||
Ireload -> 2
|
||||
| Iload(_, _) -> 2
|
||||
| Iconst_float _ -> 2 (* turned into a load *)
|
||||
| Iintop Imul -> 2 (* ends up with a load *)
|
||||
| Iaddf | Isubf | Imulf -> 3
|
||||
| Idivf -> 12
|
||||
| _ -> 1
|
||||
|
||||
(* Layout of the stack *)
|
||||
|
||||
let num_stack_slots = [| 0; 0 |]
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Reloading for the HPPA *)
|
||||
|
||||
let fundecl f =
|
||||
(new Reloadgen.reload_generic ())#fundecl f
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Instruction scheduling for the HPPA *)
|
||||
|
||||
open Arch
|
||||
open Mach
|
||||
|
||||
class scheduler () as self =
|
||||
|
||||
inherit Schedgen.scheduler_generic () as super
|
||||
|
||||
(* Latencies (in cycles). Roughly based on the ``Mustang'' chips. *)
|
||||
|
||||
method oper_latency = function
|
||||
Ireload -> 2
|
||||
| Iload(_, _) -> 2
|
||||
| Iconst_float _ -> 2 (* turned into a load *)
|
||||
| Iintop Imul -> 2 (* ends up with a load *)
|
||||
| Iaddf | Isubf | Imulf -> 3
|
||||
| Idivf -> 12
|
||||
| _ -> 1
|
||||
|
||||
(* Issue cycles. Rough approximations. *)
|
||||
|
||||
method oper_issue_cycles = function
|
||||
Iconst_float _ -> 3
|
||||
| Iconst_symbol _ -> 2
|
||||
| Iload(_, Ibased(_, _)) -> 2
|
||||
| Istore(_, Ibased(_, _)) -> 2
|
||||
| Ialloc _ -> 5
|
||||
| Iintop Imul -> 10
|
||||
| Iintop Ilsl -> 3
|
||||
| Iintop Ilsr -> 2
|
||||
| Iintop Iasr -> 3
|
||||
| Iintop(Icomp _) -> 2
|
||||
| Iintop(Icheckbound) -> 2
|
||||
| Iintop_imm(Idiv, _) -> 4
|
||||
| Iintop_imm(Imod, _) -> 5
|
||||
| Iintop_imm(Icomp _, _) -> 2
|
||||
| Iintop_imm(Icheckbound, _) -> 2
|
||||
| Ifloatofint -> 4
|
||||
| Iintoffloat -> 4
|
||||
| _ -> 1
|
||||
|
||||
end
|
||||
|
||||
let fundecl f = (new scheduler ())#schedule_fundecl f
|
||||
|
||||
|
|
@ -0,0 +1,93 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1997 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Instruction selection for the HPPA processor *)
|
||||
|
||||
open Misc
|
||||
open Cmm
|
||||
open Reg
|
||||
open Arch
|
||||
open Mach
|
||||
|
||||
let shiftadd = function
|
||||
2 -> Ishift1add
|
||||
| 4 -> Ishift2add
|
||||
| 8 -> Ishift3add
|
||||
| _ -> fatal_error "Proc_hppa.shiftadd"
|
||||
|
||||
class selector () as self =
|
||||
|
||||
inherit Selectgen.selector_generic() as super
|
||||
|
||||
method is_immediate n = (n < 16) && (n >= -16) (* 5 bits *)
|
||||
|
||||
method select_addressing = function
|
||||
Cconst_symbol s ->
|
||||
(Ibased(s, 0), Ctuple [])
|
||||
| Cop(Cadda, [Cconst_symbol s; Cconst_int n]) ->
|
||||
(Ibased(s, n), Ctuple [])
|
||||
| Cop(Cadda, [arg; Cconst_int n]) ->
|
||||
(Iindexed n, arg)
|
||||
| Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) ->
|
||||
(Iindexed n, Cop(Cadda, [arg1; arg2]))
|
||||
| arg ->
|
||||
(Iindexed 0, arg)
|
||||
|
||||
method select_operation op args =
|
||||
match (op, args) with
|
||||
(* Recognize shift-add operations. *)
|
||||
((Caddi|Cadda),
|
||||
[arg2; Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)])]) ->
|
||||
(Ispecific(shiftadd(1 lsl shift)), [arg1; arg2])
|
||||
| ((Caddi|Cadda),
|
||||
[arg2; Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)])]) ->
|
||||
(Ispecific(shiftadd mult), [arg1; arg2])
|
||||
| ((Caddi|Cadda),
|
||||
[arg2; Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1])]) ->
|
||||
(Ispecific(shiftadd mult), [arg1; arg2])
|
||||
| (Caddi, [Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)]); arg2]) ->
|
||||
(Ispecific(shiftadd(1 lsl shift)), [arg1; arg2])
|
||||
| (Caddi, [Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)]); arg2]) ->
|
||||
(Ispecific(shiftadd mult), [arg1; arg2])
|
||||
| (Caddi, [Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1]); arg2]) ->
|
||||
(Ispecific(shiftadd mult), [arg1; arg2])
|
||||
(* Prevent the recognition of some immediate arithmetic operations *)
|
||||
(* Cmuli : -> Ilsl if power of 2
|
||||
Cdivi, Cmodi : only if power of 2
|
||||
Cand, Cor, Cxor : never *)
|
||||
| (Cmuli, ([arg1; Cconst_int n] as args)) ->
|
||||
let l = Misc.log2 n in
|
||||
if n = 1 lsl l
|
||||
then (Iintop_imm(Ilsl, l), [arg1])
|
||||
else (Iintop Imul, args)
|
||||
| (Cmuli, ([Cconst_int n; arg1] as args)) ->
|
||||
let l = Misc.log2 n in
|
||||
if n = 1 lsl l
|
||||
then (Iintop_imm(Ilsl, l), [arg1])
|
||||
else (Iintop Imul, args)
|
||||
| (Cmuli, args) -> (Iintop Imul, args)
|
||||
| (Cdivi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Idiv, n), [arg1])
|
||||
| (Cdivi, args) -> (Iintop Idiv, args)
|
||||
| (Cmodi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Imod, n), [arg1])
|
||||
| (Cmodi, args) -> (Iintop Imod, args)
|
||||
| (Cand, args) -> (Iintop Iand, args)
|
||||
| (Cor, args) -> (Iintop Ior, args)
|
||||
| (Cxor, args) -> (Iintop Ixor, args)
|
||||
| _ ->
|
||||
super#select_operation op args
|
||||
|
||||
end
|
||||
|
||||
let fundecl f = (new selector ())#emit_fundecl f
|
||||
|
|
@ -504,8 +504,6 @@ let emit_instr i =
|
|||
| Lop(Ispecific(Istore_symbol(s, addr))) ->
|
||||
add_used_symbol s ;
|
||||
` mov DWORD PTR {emit_addressing addr i.arg 0},OFFSET {emit_symbol s}\n`
|
||||
| Lop(Ispecific(Ioffset_loc(n, addr))) ->
|
||||
` add DWORD PTR {emit_addressing addr i.arg 0},{emit_int n}\n`
|
||||
| Lop(Ispecific(Ipush)) ->
|
||||
(* Push arguments in reverse order *)
|
||||
for n = Array.length i.arg - 1 downto 0 do
|
||||
|
|
@ -0,0 +1,174 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Description of the Intel 386 processor *)
|
||||
|
||||
open Misc
|
||||
open Arch
|
||||
open Format
|
||||
open Cmm
|
||||
open Reg
|
||||
open Mach
|
||||
|
||||
(* Registers available for register allocation *)
|
||||
|
||||
(* Register map:
|
||||
eax 0 eax - edi: function arguments and results
|
||||
ebx 1 eax: C function results
|
||||
ecx 2 ebx, esi, edi, ebp: preserved by C
|
||||
edx 3
|
||||
esi 4
|
||||
edi 5
|
||||
ebp 6
|
||||
|
||||
tos 100 top of floating-point stack. *)
|
||||
|
||||
let int_reg_name =
|
||||
[| "%eax"; "%ebx"; "%ecx"; "%edx"; "%esi"; "%edi"; "%ebp" |]
|
||||
|
||||
let float_reg_name =
|
||||
[| "%tos" |]
|
||||
|
||||
let num_register_classes = 2
|
||||
|
||||
let register_class r =
|
||||
match r.typ with
|
||||
Int -> 0
|
||||
| Addr -> 0
|
||||
| Float -> 1
|
||||
|
||||
let num_available_registers = [| 7; 0 |]
|
||||
|
||||
let first_available_register = [| 0; 100 |]
|
||||
|
||||
let register_name r =
|
||||
if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
|
||||
|
||||
(* There is little scheduling, and some operations are more compact
|
||||
when their argument is %eax. *)
|
||||
|
||||
let rotate_registers = false
|
||||
|
||||
(* Representation of hard registers by pseudo-registers *)
|
||||
|
||||
let hard_int_reg =
|
||||
let v = Array.create 7 Reg.dummy in
|
||||
for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done;
|
||||
v
|
||||
|
||||
let hard_float_reg = [| Reg.at_location Float (Reg 100) |]
|
||||
|
||||
let all_phys_regs =
|
||||
Array.append hard_int_reg hard_float_reg
|
||||
|
||||
let phys_reg n =
|
||||
if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
|
||||
|
||||
let eax = phys_reg 0
|
||||
let ecx = phys_reg 2
|
||||
let edx = phys_reg 3
|
||||
let tos = phys_reg 100
|
||||
|
||||
let stack_slot slot ty =
|
||||
Reg.at_location ty (Stack slot)
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
let word_addressed = false
|
||||
|
||||
(* Calling conventions *)
|
||||
|
||||
let calling_conventions first_int last_int first_float last_float make_stack
|
||||
arg =
|
||||
let loc = Array.create (Array.length arg) Reg.dummy in
|
||||
let int = ref first_int in
|
||||
let float = ref first_float in
|
||||
let ofs = ref 0 in
|
||||
for i = 0 to Array.length arg - 1 do
|
||||
match arg.(i).typ with
|
||||
Int | Addr as ty ->
|
||||
if !int <= last_int then begin
|
||||
loc.(i) <- phys_reg !int;
|
||||
incr int
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) ty;
|
||||
ofs := !ofs + size_int
|
||||
end
|
||||
| Float ->
|
||||
if !float <= last_float then begin
|
||||
loc.(i) <- phys_reg !float;
|
||||
incr float
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) Float;
|
||||
ofs := !ofs + size_float
|
||||
end
|
||||
done;
|
||||
(loc, !ofs)
|
||||
|
||||
let incoming ofs = Incoming ofs
|
||||
let outgoing ofs = Outgoing ofs
|
||||
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
|
||||
|
||||
let loc_arguments arg =
|
||||
calling_conventions 0 5 100 99 outgoing arg
|
||||
let loc_parameters arg =
|
||||
let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc
|
||||
let loc_results res =
|
||||
let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc
|
||||
let extcall_use_push = true
|
||||
let loc_external_arguments arg =
|
||||
fatal_error "Proc.loc_external_arguments"
|
||||
let loc_external_results res =
|
||||
let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
|
||||
|
||||
let loc_exn_bucket = eax
|
||||
|
||||
(* Registers destroyed by operations *)
|
||||
|
||||
let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *)
|
||||
[|eax; ecx; edx|]
|
||||
|
||||
let destroyed_at_oper = function
|
||||
Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
|
||||
| Iop(Iextcall(_, false)) -> destroyed_at_c_call
|
||||
| Iop(Iintop(Idiv | Imod)) -> [| eax; edx |]
|
||||
| Iop(Iintop_imm(Imod, _)) -> [| eax |]
|
||||
| Iop(Ialloc _) -> [| eax |]
|
||||
| Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |]
|
||||
| Iop(Iintoffloat) -> [| eax |]
|
||||
| Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |]
|
||||
| _ -> [||]
|
||||
|
||||
let destroyed_at_raise = all_phys_regs
|
||||
|
||||
(* Maximal register pressure *)
|
||||
|
||||
let safe_register_pressure op = 4
|
||||
|
||||
let max_register_pressure = function
|
||||
Iextcall(_, _) -> [| 4; max_int |]
|
||||
| Iintop(Idiv | Imod) -> [| 5; max_int |]
|
||||
| Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) |
|
||||
Iintoffloat -> [| 6; max_int |]
|
||||
| _ -> [|7; max_int |]
|
||||
|
||||
(* Layout of the stack frame *)
|
||||
|
||||
let num_stack_slots = [| 0; 0 |]
|
||||
let contains_calls = ref false
|
||||
|
||||
(* Calling the assembler *)
|
||||
|
||||
let assemble_file infile outfile =
|
||||
Ccomp.command ("as -o " ^ outfile ^ " " ^ infile)
|
||||
|
||||
|
|
@ -0,0 +1,177 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Description of the Intel 386 processor, for Windows NT *)
|
||||
|
||||
open Misc
|
||||
open Arch
|
||||
open Format
|
||||
open Cmm
|
||||
open Reg
|
||||
open Mach
|
||||
|
||||
(* Registers available for register allocation *)
|
||||
|
||||
(* Register map:
|
||||
eax 0 eax - edi: function arguments and results
|
||||
ebx 1 eax: C function results
|
||||
ecx 2 ebx, esi, edi, ebp: preserved by C
|
||||
edx 3
|
||||
esi 4
|
||||
edi 5
|
||||
ebp 6
|
||||
|
||||
tos 100 top of floating-point stack. *)
|
||||
|
||||
let int_reg_name =
|
||||
[| "eax"; "ebx"; "ecx"; "edx"; "esi"; "edi"; "ebp" |]
|
||||
|
||||
let float_reg_name =
|
||||
[| "tos" |]
|
||||
|
||||
let num_register_classes = 2
|
||||
|
||||
let register_class r =
|
||||
match r.typ with
|
||||
Int -> 0
|
||||
| Addr -> 0
|
||||
| Float -> 1
|
||||
|
||||
let num_available_registers = [| 7; 0 |]
|
||||
|
||||
let first_available_register = [| 0; 100 |]
|
||||
|
||||
let register_name r =
|
||||
if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
|
||||
|
||||
(* There is little scheduling, and some operations are more compact
|
||||
when their argument is %eax. *)
|
||||
|
||||
let rotate_registers = false
|
||||
|
||||
(* Representation of hard registers by pseudo-registers *)
|
||||
|
||||
let hard_int_reg =
|
||||
let v = Array.create 7 Reg.dummy in
|
||||
for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done;
|
||||
v
|
||||
|
||||
let hard_float_reg = [| Reg.at_location Float (Reg 100) |]
|
||||
|
||||
let all_phys_regs =
|
||||
Array.append hard_int_reg hard_float_reg
|
||||
|
||||
let phys_reg n =
|
||||
if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
|
||||
|
||||
let eax = phys_reg 0
|
||||
let ecx = phys_reg 2
|
||||
let edx = phys_reg 3
|
||||
let tos = phys_reg 100
|
||||
|
||||
let stack_slot slot ty =
|
||||
Reg.at_location ty (Stack slot)
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
let word_addressed = false
|
||||
|
||||
(* Calling conventions *)
|
||||
|
||||
let calling_conventions first_int last_int first_float last_float make_stack
|
||||
arg =
|
||||
let loc = Array.create (Array.length arg) Reg.dummy in
|
||||
let int = ref first_int in
|
||||
let float = ref first_float in
|
||||
let ofs = ref 0 in
|
||||
for i = 0 to Array.length arg - 1 do
|
||||
match arg.(i).typ with
|
||||
Int | Addr as ty ->
|
||||
if !int <= last_int then begin
|
||||
loc.(i) <- phys_reg !int;
|
||||
incr int
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) ty;
|
||||
ofs := !ofs + size_int
|
||||
end
|
||||
| Float ->
|
||||
if !float <= last_float then begin
|
||||
loc.(i) <- phys_reg !float;
|
||||
incr float
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) Float;
|
||||
ofs := !ofs + size_float
|
||||
end
|
||||
done;
|
||||
(loc, !ofs)
|
||||
|
||||
let incoming ofs = Incoming ofs
|
||||
let outgoing ofs = Outgoing ofs
|
||||
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
|
||||
|
||||
let loc_arguments arg =
|
||||
calling_conventions 0 5 100 99 outgoing arg
|
||||
let loc_parameters arg =
|
||||
let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc
|
||||
let loc_results res =
|
||||
let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc
|
||||
let extcall_use_push = true
|
||||
let loc_external_arguments arg =
|
||||
fatal_error "Proc.loc_external_arguments"
|
||||
let loc_external_results res =
|
||||
let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
|
||||
|
||||
let loc_exn_bucket = eax
|
||||
|
||||
(* Registers destroyed by operations *)
|
||||
|
||||
let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *)
|
||||
Array.of_list(List.map phys_reg [0;2;3])
|
||||
|
||||
let destroyed_at_oper = function
|
||||
Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
|
||||
| Iop(Iextcall(_, false)) -> destroyed_at_c_call
|
||||
| Iop(Iintop(Idiv | Imod)) -> [| eax; edx |]
|
||||
| Iop(Iintop_imm(Imod, _)) -> [| eax |]
|
||||
| Iop(Ialloc _) -> [| eax |]
|
||||
| Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |]
|
||||
| Iop(Iintoffloat) -> [| eax |]
|
||||
| Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |]
|
||||
| _ -> [||]
|
||||
|
||||
let destroyed_at_raise = all_phys_regs
|
||||
|
||||
(* Maximal register pressure *)
|
||||
|
||||
let safe_register_pressure op = 4
|
||||
|
||||
let max_register_pressure = function
|
||||
Iextcall(_, _) -> [| 4; max_int |]
|
||||
| Iintop(Idiv | Imod) -> [| 5; max_int |]
|
||||
| Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) |
|
||||
Iintoffloat -> [| 6; max_int |]
|
||||
| _ -> [|7; max_int |]
|
||||
|
||||
(* Layout of the stack frame *)
|
||||
|
||||
let num_stack_slots = [| 0; 0 |]
|
||||
let contains_calls = ref false
|
||||
|
||||
(* Calling the assembler *)
|
||||
|
||||
let assemble_file infile outfile =
|
||||
Ccomp.command ("ml /nologo /coff /Cp /c /Fo" ^ outfile ^ " " ^ infile ^ ">NUL")
|
||||
(* /Cp preserve case of all used identifiers
|
||||
/c assemble only
|
||||
/Fo output file name *)
|
||||
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Cmm
|
||||
open Arch
|
||||
open Reg
|
||||
open Mach
|
||||
|
||||
(* Reloading for the Intel x86 *)
|
||||
|
||||
let stackp r =
|
||||
match r.loc with
|
||||
Stack _ -> true
|
||||
| _ -> false
|
||||
|
||||
class reload () as self =
|
||||
|
||||
inherit Reloadgen.reload_generic () as super
|
||||
|
||||
method makereg r =
|
||||
match r.typ with
|
||||
Float -> r
|
||||
| _ -> super#makereg r
|
||||
|
||||
(* By overriding makereg, we make sure that pseudoregs of type float
|
||||
will never be reloaded. Hence there is no need to make special cases for
|
||||
floating-point operations. *)
|
||||
|
||||
method reload_operation op arg res =
|
||||
match op with
|
||||
Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor|Icomp _|Icheckbound) ->
|
||||
(* One of the two arguments can reside in the stack *)
|
||||
if stackp arg.(0) && stackp arg.(1)
|
||||
then ([|arg.(0); self#makereg arg.(1)|], res)
|
||||
else (arg, res)
|
||||
| Iintop(Ilsl|Ilsr|Iasr) | Iintop_imm(_, _) | Ifloatofint | Iintoffloat |
|
||||
Ispecific(Ipush) ->
|
||||
(* The argument(s) can be either in register or on stack *)
|
||||
(arg, res)
|
||||
| _ -> (* Other operations: all args and results in registers *)
|
||||
super#reload_operation op arg res
|
||||
|
||||
method reload_test tst arg =
|
||||
match tst with
|
||||
Iinttest cmp ->
|
||||
(* One of the two arguments can reside on stack *)
|
||||
if stackp arg.(0) && stackp arg.(1)
|
||||
then [| self#makereg arg.(0); arg.(1) |]
|
||||
else arg
|
||||
| _ ->
|
||||
(* The argument(s) can be either in register or on stack *)
|
||||
arg
|
||||
|
||||
end
|
||||
|
||||
let fundecl f =
|
||||
(new reload ())#fundecl f
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Schedgen (* to create a dependency *)
|
||||
|
||||
(* Scheduling is turned off because our model does not fit the 486
|
||||
nor Pentium very well. In particular, it messes up with the
|
||||
float reg stack. The Pentium Pro schedules at run-time much better
|
||||
than what we could do. *)
|
||||
|
||||
let fundecl f = f
|
||||
|
|
@ -0,0 +1,262 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1997 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Instruction selection for the Intel x86 *)
|
||||
|
||||
open Misc
|
||||
open Arch
|
||||
open Proc
|
||||
open Cmm
|
||||
open Reg
|
||||
open Mach
|
||||
|
||||
(* Auxiliary for recognizing addressing modes *)
|
||||
|
||||
type addressing_expr =
|
||||
Asymbol of string
|
||||
| Alinear of expression
|
||||
| Aadd of expression * expression
|
||||
| Ascale of expression * int
|
||||
| Ascaledadd of expression * expression * int
|
||||
|
||||
let rec select_addr exp =
|
||||
match exp with
|
||||
Cconst_symbol s ->
|
||||
(Asymbol s, 0)
|
||||
| Cop((Caddi | Cadda), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Csubi | Csuba), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n - m)
|
||||
| Cop((Caddi | Cadda), [Cconst_int m; arg]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, mult), n * mult)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, mult), n * mult)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop((Caddi | Cadda), [arg1; arg2]) ->
|
||||
begin match (select_addr arg1, select_addr arg2) with
|
||||
((Alinear e1, n1), (Alinear e2, n2)) ->
|
||||
(Aadd(e1, e2), n1 + n2)
|
||||
| ((Alinear e1, n1), (Ascale(e2, scale), n2)) ->
|
||||
(Ascaledadd(e1, e2, scale), n1 + n2)
|
||||
| ((Ascale(e1, scale), n1), (Alinear e2, n2)) ->
|
||||
(Ascaledadd(e2, e1, scale), n1 + n2)
|
||||
| (_, (Ascale(e2, scale), n2)) ->
|
||||
(Ascaledadd(arg1, e2, scale), n2)
|
||||
| ((Ascale(e1, scale), n1), _) ->
|
||||
(Ascaledadd(arg2, e1, scale), n1)
|
||||
| _ ->
|
||||
(Aadd(arg1, arg2), 0)
|
||||
end
|
||||
| arg ->
|
||||
(Alinear arg, 0)
|
||||
|
||||
(* Estimate number of float temporaries needed to evaluate expression
|
||||
(Ershov's algorithm) *)
|
||||
|
||||
let rec float_needs = function
|
||||
Cop((Caddf | Csubf | Cmulf | Cdivf), [arg1; arg2]) ->
|
||||
let n1 = float_needs arg1 in
|
||||
let n2 = float_needs arg2 in
|
||||
if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2
|
||||
| _ ->
|
||||
1
|
||||
|
||||
(* Special constraints on operand and result registers *)
|
||||
|
||||
exception Use_default
|
||||
|
||||
let eax = phys_reg 0
|
||||
let ecx = phys_reg 2
|
||||
let edx = phys_reg 3
|
||||
let tos = phys_reg 100
|
||||
|
||||
let pseudoregs_for_operation op arg res =
|
||||
match op with
|
||||
(* Two-address binary operations *)
|
||||
Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) ->
|
||||
([|res.(0); arg.(1)|], res, false)
|
||||
(* Two-address unary operations *)
|
||||
| Iintop_imm((Iadd|Isub|Imul|Idiv|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) ->
|
||||
(res, res, false)
|
||||
(* For shifts with variable shift count, second arg must be in ecx *)
|
||||
| Iintop(Ilsl|Ilsr|Iasr) ->
|
||||
([|res.(0); ecx|], res, false)
|
||||
(* For div and mod, first arg must be in eax, edx is clobbered,
|
||||
and result is in eax or edx respectively.
|
||||
Keep it simple, just force second argument in ecx. *)
|
||||
| Iintop(Idiv) ->
|
||||
([| eax; ecx |], [| eax |], true)
|
||||
| Iintop(Imod) ->
|
||||
([| eax; ecx |], [| edx |], true)
|
||||
(* For mod with immediate operand, arg must not be in eax.
|
||||
Keep it simple, force it in edx. *)
|
||||
| Iintop_imm(Imod, _) ->
|
||||
([| edx |], [| edx |], true)
|
||||
(* For floating-point operations, the result is always left at the
|
||||
top of the floating-point stack *)
|
||||
| Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
|
||||
| Ifloatofint |Ispecific(Isubfrev | Idivfrev | Ifloatarithmem(_, _)) ->
|
||||
(arg, [| tos |], false) (* don't move it immediately *)
|
||||
(* Same for a floating-point load *)
|
||||
| Iload(Word, addr) when res.(0).typ = Float ->
|
||||
(arg, [| tos |], false)
|
||||
(* For storing a byte, the argument must be in eax...edx.
|
||||
For storing a halfword, any reg is ok.
|
||||
Keep it simple, just force it to be in edx in both cases. *)
|
||||
| Istore(Word, addr) -> raise Use_default
|
||||
| Istore(chunk, addr) ->
|
||||
let newarg = Array.copy arg in
|
||||
newarg.(0) <- edx;
|
||||
(newarg, res, false)
|
||||
(* Other instructions are regular *)
|
||||
| _ -> raise Use_default
|
||||
|
||||
(* The selector class *)
|
||||
|
||||
class selector () as self =
|
||||
|
||||
inherit Selectgen.selector_generic() as super
|
||||
|
||||
method is_immediate (n : int) = true
|
||||
|
||||
method select_addressing exp =
|
||||
match select_addr exp with
|
||||
(Asymbol s, d) ->
|
||||
(Ibased(s, d), Ctuple [])
|
||||
| (Alinear e, d) ->
|
||||
(Iindexed d, e)
|
||||
| (Aadd(e1, e2), d) ->
|
||||
(Iindexed2 d, Ctuple[e1; e2])
|
||||
| (Ascale(e, scale), d) ->
|
||||
(Iscaled(scale, d), e)
|
||||
| (Ascaledadd(e1, e2, scale), d) ->
|
||||
(Iindexed2scaled(scale, d), Ctuple[e1; e2])
|
||||
|
||||
method select_store addr exp =
|
||||
match exp with
|
||||
Cconst_int n -> (Ispecific(Istore_int(n, addr)), Ctuple [])
|
||||
| Cconst_pointer n -> (Ispecific(Istore_int(n, addr)), Ctuple [])
|
||||
| Cconst_symbol s -> (Ispecific(Istore_symbol(s, addr)), Ctuple [])
|
||||
| _ -> super#select_store addr exp
|
||||
|
||||
method select_operation op args =
|
||||
match op with
|
||||
(* Recognize the LEA instruction *)
|
||||
Caddi | Cadda | Csubi | Csuba ->
|
||||
begin match self#select_addressing (Cop(op, args)) with
|
||||
(Iindexed d, _) -> super#select_operation op args
|
||||
| (Iindexed2 0, _) -> super#select_operation op args
|
||||
| (addr, arg) -> (Ispecific(Ilea addr), [arg])
|
||||
end
|
||||
(* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *)
|
||||
| Cdivi ->
|
||||
begin match args with
|
||||
[arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Idiv, n), [arg1])
|
||||
| _ -> (Iintop Idiv, args)
|
||||
end
|
||||
| Cmodi ->
|
||||
begin match args with
|
||||
[arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Imod, n), [arg1])
|
||||
| _ -> (Iintop Imod, args)
|
||||
end
|
||||
(* Recognize float arithmetic with memory.
|
||||
In passing, apply Ershov's algorithm to reduce stack usage *)
|
||||
| Caddf ->
|
||||
self#select_floatarith Iaddf Iaddf Ifloatadd Ifloatadd args
|
||||
| Csubf ->
|
||||
self#select_floatarith Isubf (Ispecific Isubfrev) Ifloatsub Ifloatsubrev args
|
||||
| Cmulf ->
|
||||
self#select_floatarith Imulf Imulf Ifloatmul Ifloatmul args
|
||||
| Cdivf ->
|
||||
self#select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev args
|
||||
| _ -> super#select_operation op args
|
||||
|
||||
(* Recognize float arithmetic with mem *)
|
||||
|
||||
method select_floatarith regular_op reversed_op mem_op mem_rev_op args =
|
||||
match args with
|
||||
[arg1; Cop(Cload _, [loc2])] ->
|
||||
let (addr, arg2) = self#select_addressing loc2 in
|
||||
(Ispecific(Ifloatarithmem(mem_op, addr)), [arg1; arg2])
|
||||
| [Cop(Cload _, [loc1]); arg2] ->
|
||||
let (addr, arg1) = self#select_addressing loc1 in
|
||||
(Ispecific(Ifloatarithmem(mem_rev_op, addr)), [arg2; arg1])
|
||||
| [arg1; arg2] ->
|
||||
(* Evaluate bigger subexpression first to minimize stack usage.
|
||||
Because of right-to-left evaluation, rightmost arg is evaluated
|
||||
first *)
|
||||
if float_needs arg1 <= float_needs arg2
|
||||
then (regular_op, [arg1; arg2])
|
||||
else (reversed_op, [arg2; arg1])
|
||||
| _ ->
|
||||
fatal_error "Proc_i386: select_floatarith"
|
||||
|
||||
(* Deal with register constraints *)
|
||||
|
||||
method insert_op op rs rd =
|
||||
try
|
||||
let (rsrc, rdst, move_res) = pseudoregs_for_operation op rs rd in
|
||||
self#insert_moves rs rsrc;
|
||||
self#insert (Iop op) rsrc rdst;
|
||||
if move_res then begin
|
||||
self#insert_moves rdst rd;
|
||||
rd
|
||||
end else
|
||||
rdst
|
||||
with Use_default ->
|
||||
super#insert_op op rs rd
|
||||
|
||||
(* Selection of push instructions for external calls *)
|
||||
|
||||
method select_push exp =
|
||||
match exp with
|
||||
Cconst_int n -> (Ispecific(Ipush_int n), Ctuple [])
|
||||
| Cconst_pointer n -> (Ispecific(Ipush_int n), Ctuple [])
|
||||
| Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
|
||||
| Cop(Cload ty, [loc]) when ty = typ_float ->
|
||||
let (addr, arg) = self#select_addressing loc in
|
||||
(Ispecific(Ipush_load_float addr), arg)
|
||||
| Cop(Cload ty, [loc]) when ty = typ_addr or ty = typ_int ->
|
||||
let (addr, arg) = self#select_addressing loc in
|
||||
(Ispecific(Ipush_load addr), arg)
|
||||
| _ -> (Ispecific(Ipush), exp)
|
||||
|
||||
method emit_extcall_args env args =
|
||||
let rec emit_pushes = function
|
||||
[] -> 0
|
||||
| e :: el ->
|
||||
let ofs = emit_pushes el in
|
||||
let (op, arg) = self#select_push e in
|
||||
let r = self#emit_expr env arg in
|
||||
self#insert (Iop op) r [||];
|
||||
ofs + Selectgen.size_expr env e
|
||||
in ([||], emit_pushes args)
|
||||
|
||||
end
|
||||
|
||||
let fundecl f = (new selector ())#emit_fundecl f
|
||||
|
||||
|
|
@ -0,0 +1,156 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Description of the Motorola 680x0 processor *)
|
||||
|
||||
open Misc
|
||||
open Arch
|
||||
open Format
|
||||
open Cmm
|
||||
open Reg
|
||||
open Mach
|
||||
|
||||
(* Registers available for register allocation *)
|
||||
|
||||
(* Register map:
|
||||
A0 - A6 0-6 address registers (A2-A6 callee-save)
|
||||
A7 stack pointer
|
||||
D0 - D4 7-11 data registers (D2 - D7 callee-save)
|
||||
D5 temporary
|
||||
D6 allocation pointer
|
||||
D7 trap pointer
|
||||
FP0 - FP7 12-19 floating-point registers (FP2 - FP7 callee-save)
|
||||
*)
|
||||
|
||||
let register_names =
|
||||
[| "a0"; "a1"; "a2"; "a3"; "a4"; "a5"; "a6";
|
||||
"d0"; "d1"; "d2"; "d3"; "d4";
|
||||
"fp0"; "fp1"; "fp2"; "fp3"; "fp4"; "fp5"; "fp6"; "fp7" |]
|
||||
|
||||
let num_register_classes = 3
|
||||
|
||||
let register_class r =
|
||||
match r.typ with
|
||||
Addr -> 0
|
||||
| Int -> 1
|
||||
| Float -> 2
|
||||
|
||||
let num_available_registers = [| 7; 5; 8 |]
|
||||
|
||||
let first_available_register = [| 0; 7; 12 |]
|
||||
|
||||
let register_name r = register_names.(r)
|
||||
|
||||
(* There is no scheduling, so just pack registers. *)
|
||||
|
||||
let rotate_registers = false
|
||||
|
||||
(* Representation of hard registers by pseudo-registers *)
|
||||
|
||||
let all_phys_regs =
|
||||
let v = Array.create 20 Reg.dummy in
|
||||
for i = 0 to 6 do v.(i) <- Reg.at_location Addr (Reg i) done;
|
||||
for i = 7 to 11 do v.(i) <- Reg.at_location Int (Reg i) done;
|
||||
for i = 12 to 19 do v.(i) <- Reg.at_location Float (Reg i) done;
|
||||
v
|
||||
|
||||
let phys_reg n = all_phys_regs.(n)
|
||||
|
||||
let stack_slot slot ty = Reg.at_location ty (Stack slot)
|
||||
|
||||
let reg_A0 = phys_reg 0
|
||||
let reg_FP0 = phys_reg 12
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
let word_addressed = false
|
||||
|
||||
(* Calling conventions *)
|
||||
|
||||
let calling_conventions first_addr last_addr first_float last_float
|
||||
make_stack arg =
|
||||
let loc = Array.create (Array.length arg) Reg.dummy in
|
||||
let addr = ref first_addr in
|
||||
let float = ref first_float in
|
||||
let ofs = ref 0 in
|
||||
for i = 0 to Array.length arg - 1 do
|
||||
match arg.(i).typ with
|
||||
(Addr | Int) as ty ->
|
||||
if !addr <= last_addr then begin
|
||||
loc.(i) <- phys_reg !addr;
|
||||
incr addr
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) ty;
|
||||
ofs := !ofs + size_addr
|
||||
end
|
||||
| Float ->
|
||||
if !float <= last_float then begin
|
||||
loc.(i) <- phys_reg !float;
|
||||
incr float
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) Float;
|
||||
ofs := !ofs + size_float
|
||||
end
|
||||
done;
|
||||
(loc, !ofs)
|
||||
|
||||
let incoming ofs = Incoming ofs
|
||||
let outgoing ofs = Outgoing ofs
|
||||
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
|
||||
|
||||
let loc_arguments arg =
|
||||
calling_conventions 0 5 12 18 outgoing arg
|
||||
let loc_parameters arg =
|
||||
let (loc, ofs) = calling_conventions 0 5 12 18 incoming arg in loc
|
||||
let loc_results res =
|
||||
let (loc, ofs) = calling_conventions 0 5 12 18 not_supported res in loc
|
||||
let extcall_use_push = true
|
||||
let loc_external_arguments arg =
|
||||
fatal_error "Proc.loc_external_arguments"
|
||||
let loc_external_results res =
|
||||
let (loc, ofs) = calling_conventions 7 7 12 12 not_supported res in loc
|
||||
|
||||
let loc_exn_bucket = reg_A0
|
||||
|
||||
(* Registers destroyed by operations *)
|
||||
|
||||
let destroyed_at_c_call =
|
||||
Array.of_list(List.map phys_reg [0; 1; 7; 8; 12; 13])
|
||||
|
||||
let destroyed_at_oper = function
|
||||
Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
|
||||
| Iop(Iextcall(_, false)) -> destroyed_at_c_call
|
||||
| Iop(Iintoffloat) -> [| reg_FP0 |]
|
||||
| _ -> [||]
|
||||
|
||||
let destroyed_at_raise = all_phys_regs
|
||||
|
||||
(* Maximal register pressure *)
|
||||
|
||||
let safe_register_pressure op = 5
|
||||
|
||||
let max_register_pressure = function
|
||||
Iextcall(_, _) -> [| 5; 3; 6 |]
|
||||
| Iintoffloat -> [| 7; 5; 7 |]
|
||||
| _ -> num_available_registers
|
||||
|
||||
(* Layout of the stack frame *)
|
||||
|
||||
let num_stack_slots = [| 0; 0; 0 |]
|
||||
let contains_calls = ref false
|
||||
|
||||
(* Calling the assembler *)
|
||||
|
||||
let assemble_file infile outfile =
|
||||
Ccomp.command ("as -o " ^ outfile ^ " " ^ infile)
|
||||
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Reloading for the Motorola 68k *)
|
||||
|
||||
open Cmm
|
||||
open Arch
|
||||
open Reg
|
||||
open Mach
|
||||
|
||||
let stackp r =
|
||||
match r.loc with
|
||||
Stack _ -> true
|
||||
| _ -> false
|
||||
|
||||
class reload () as self =
|
||||
|
||||
inherit Reloadgen.reload_generic () as super
|
||||
|
||||
method reload_operation op arg res =
|
||||
match op with
|
||||
Imove | Ireload | Ispill |
|
||||
Iintop_imm((Iadd | Isub | Iand | Ior | Ixor |
|
||||
Icomp _ | Ilsl | Ilsr | Iasr), _) |
|
||||
Ifloatofint | Iintoffloat | Ispecific(Ipush) ->
|
||||
(* The argument(s) can be either in register or on stack *)
|
||||
(arg, res)
|
||||
| Iintop(Iadd | Isub | Iand | Ior | Ixor | Icomp _) ->
|
||||
(* One of the two arguments can reside in the stack *)
|
||||
if stackp arg.(0) && stackp arg.(1)
|
||||
then ([|arg.(0); self#makereg arg.(1)|], res)
|
||||
else (arg, res)
|
||||
| Iintop(Ilsl | Ilsr | Iasr) ->
|
||||
(* The first argument and result can reside in the stack *)
|
||||
([|arg.(0); self#makereg arg.(1)|], res)
|
||||
| Iintop(Imul | Idiv | Imod) | Iaddf | Isubf | Imulf | Idivf ->
|
||||
(* The second argument can reside in the stack *)
|
||||
let r = self#makereg arg.(0) in ([|r; arg.(1)|], [|r|])
|
||||
| _ -> (* Other operations: all args and results in registers *)
|
||||
super#reload_operation op arg res
|
||||
|
||||
method reload_test tst arg =
|
||||
match tst with
|
||||
Iinttest _ | Ifloattest _ ->
|
||||
(* The second argument can be on stack *)
|
||||
[| self#makereg arg.(0); arg.(1) |]
|
||||
| _ ->
|
||||
(* The argument can be on stack *)
|
||||
arg
|
||||
|
||||
end
|
||||
|
||||
let fundecl f =
|
||||
(new reload ())#fundecl f
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Schedgen (* to create a dependency *)
|
||||
|
||||
(* No scheduling is needed for the Motorola 68k. *)
|
||||
|
||||
let fundecl f = f
|
||||
|
|
@ -0,0 +1,188 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1997 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Instruction selection for the Motorola 68k *)
|
||||
|
||||
open Misc
|
||||
open Cmm
|
||||
open Reg
|
||||
open Arch
|
||||
open Mach
|
||||
|
||||
(* Auxiliary for recognizing addressing modes *)
|
||||
|
||||
type addressing_expr =
|
||||
Asymbol of string
|
||||
| Alinear of expression
|
||||
| Aadd of expression * expression
|
||||
| Ascale of expression * int
|
||||
| Ascaledadd of expression * expression * int
|
||||
|
||||
let rec select_addr exp =
|
||||
match exp with
|
||||
Cconst_symbol s ->
|
||||
(Asymbol s, 0)
|
||||
| Cop((Caddi | Cadda), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Csubi | Csuba), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n - m)
|
||||
| Cop((Caddi | Cadda), [Cconst_int m; arg]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, mult), n * mult)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, mult), n * mult)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop((Caddi | Cadda), [arg1; arg2]) ->
|
||||
begin match (select_addr arg1, select_addr arg2) with
|
||||
((Alinear e1, n1), (Alinear e2, n2)) ->
|
||||
(Aadd(e1, e2), n1 + n2)
|
||||
| ((Alinear e1, n1), (Ascale(e2, scale), n2)) ->
|
||||
(Ascaledadd(e1, e2, scale), n1 + n2)
|
||||
| ((Ascale(e1, scale), n1), (Alinear e2, n2)) ->
|
||||
(Ascaledadd(e2, e1, scale), n1 + n2)
|
||||
| (_, (Ascale(e2, scale), n2)) ->
|
||||
(Ascaledadd(arg1, e2, scale), n2)
|
||||
| ((Ascale(e1, scale), n1), _) ->
|
||||
(Ascaledadd(arg2, e1, scale), n1)
|
||||
| _ ->
|
||||
(Aadd(arg1, arg2), 0)
|
||||
end
|
||||
| arg ->
|
||||
(Alinear arg, 0)
|
||||
|
||||
(* Special constraints on operand and result registers for two-address
|
||||
instructions *)
|
||||
|
||||
exception Use_default
|
||||
|
||||
let pseudoregs_for_operation op arg res =
|
||||
match op with
|
||||
(* Two-address binary operations *)
|
||||
Iintop(Iadd | Isub | Imul | Idiv | Imod | Ilsl | Ilsr | Iasr) |
|
||||
Iaddf | Isubf | Imulf | Idivf ->
|
||||
([|res.(0); arg.(1)|], res, false)
|
||||
(* Two-address binary operations, forcing the second argument to be
|
||||
in a data register *)
|
||||
| Iintop(Iand | Ior | Ixor) ->
|
||||
let newarg1 = Reg.create Int in
|
||||
([|res.(0); newarg1|], res, false)
|
||||
(* Two-address unary operations *)
|
||||
| Iintop_imm((Iadd | Isub | Imul | Idiv | Imod | Iand | Ior | Ixor |
|
||||
Ilsl | Ilsr | Iasr), _) ->
|
||||
(res, res, false)
|
||||
(* Other instructions are regular *)
|
||||
| _ -> raise Use_default
|
||||
|
||||
(* The selector *)
|
||||
|
||||
class selector () as self =
|
||||
|
||||
inherit Selectgen.selector_generic() as super
|
||||
|
||||
method is_immediate (n : int) = true
|
||||
|
||||
(* Select addressing modes *)
|
||||
method select_addressing exp =
|
||||
match select_addr exp with
|
||||
(Asymbol s, d) ->
|
||||
(Ibased(s, d), Ctuple [])
|
||||
| (Alinear e, d) ->
|
||||
(Iindexed d, e)
|
||||
| (Aadd(e1, e2), d) ->
|
||||
(Iindexed2 d, Ctuple[e1; e2])
|
||||
| (Ascale(e, scale), d) ->
|
||||
(Iscaled(scale, d), e)
|
||||
| (Ascaledadd(e1, e2, scale), d) ->
|
||||
(Iindexed2scaled(scale, d), Ctuple[e1; e2])
|
||||
|
||||
method select_operation op args =
|
||||
match op with
|
||||
(* Recognize the LEA instruction *)
|
||||
Cadda | Csuba ->
|
||||
begin match self#select_addressing (Cop(op, args)) with
|
||||
(Iindexed d, _) -> super#select_operation op args
|
||||
| (addr, arg) -> (Ispecific(Ilea addr), [arg])
|
||||
end
|
||||
| _ ->
|
||||
super#select_operation op args
|
||||
|
||||
(* Selection of immediate shifts -- only if count is between 1 and 8 *)
|
||||
|
||||
method select_shift op = function
|
||||
[arg1; Cconst_int n] when n >= 1 && n <= 8 -> (Iintop_imm(op, n), [arg1])
|
||||
| args -> (Iintop op, args)
|
||||
|
||||
(* Select store operations *)
|
||||
|
||||
method select_store addr exp =
|
||||
match exp with
|
||||
Cconst_int n -> (Ispecific(Istore_int(n, addr)), Ctuple [])
|
||||
| Cconst_pointer n -> (Ispecific(Istore_int(n, addr)), Ctuple [])
|
||||
| Cconst_symbol s -> (Ispecific(Istore_symbol(s, addr)), Ctuple [])
|
||||
| _ -> raise Use_default
|
||||
|
||||
(* Deal with register constraints *)
|
||||
|
||||
method insert_op op rs rd =
|
||||
try
|
||||
let (rsrc, rdst, move_res) = pseudoregs_for_operation op rs rd in
|
||||
self#insert_moves rs rsrc;
|
||||
self#insert (Iop op) rsrc rdst;
|
||||
if move_res then begin
|
||||
self#insert_moves rdst rd;
|
||||
rd
|
||||
end else
|
||||
rdst
|
||||
with Use_default ->
|
||||
super#insert_op op rs rd
|
||||
|
||||
(* Select push operations for external calls *)
|
||||
|
||||
method select_push exp =
|
||||
match exp with
|
||||
Cconst_int n -> (Ispecific(Ipush_int n), Ctuple [])
|
||||
| Cconst_pointer n -> (Ispecific(Ipush_int n), Ctuple [])
|
||||
| Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
|
||||
| Cop(Cload ty, [loc]) when ty = typ_float ->
|
||||
let (addr, arg) = self#select_addressing loc in
|
||||
(Ispecific(Ipush_load_float addr), arg)
|
||||
| Cop(Cload ty, [loc]) when ty = typ_addr or ty = typ_int ->
|
||||
let (addr, arg) = self#select_addressing loc in
|
||||
(Ispecific(Ipush_load addr), arg)
|
||||
| _ -> (Ispecific(Ipush), exp)
|
||||
|
||||
method emit_extcall_args env args =
|
||||
let rec emit_pushes = function
|
||||
[] -> 0
|
||||
| e :: el ->
|
||||
let ofs = emit_pushes el in
|
||||
let (op, arg) = self#select_push e in
|
||||
let r = self#emit_expr env arg in
|
||||
self#insert (Iop op) r [||];
|
||||
ofs + Selectgen.size_expr env e
|
||||
in ([||], emit_pushes args)
|
||||
|
||||
end
|
||||
|
||||
let fundecl f = (new selector ())#emit_fundecl f
|
||||
|
|
@ -25,28 +25,6 @@ exception Use_default
|
|||
|
||||
(* Instruction selection *)
|
||||
|
||||
let select_addressing = function
|
||||
Cconst_symbol s ->
|
||||
(Ibased(s, 0), Ctuple [])
|
||||
| Cop(Cadda, [Cconst_symbol s; Cconst_int n]) ->
|
||||
(Ibased(s, n), Ctuple [])
|
||||
| Cop(Cadda, [arg; Cconst_int n]) ->
|
||||
(Iindexed n, arg)
|
||||
| Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) ->
|
||||
(Iindexed n, Cop(Cadda, [arg1; arg2]))
|
||||
| arg ->
|
||||
(Iindexed 0, arg)
|
||||
|
||||
let select_oper op args = raise Use_default
|
||||
|
||||
let select_store addr exp = raise Use_default
|
||||
|
||||
let select_push exp = fatal_error "Proc: select_push"
|
||||
|
||||
let pseudoregs_for_operation op arg res = raise Use_default
|
||||
|
||||
let is_immediate (n:int) = true
|
||||
|
||||
let word_addressed = false
|
||||
|
||||
(* Registers available for register allocation *)
|
||||
|
|
@ -186,8 +164,6 @@ let loc_external_arguments arg =
|
|||
| _ ->
|
||||
fatal_error "Proc_mips.loc_external_arguments"
|
||||
|
||||
let extcall_use_push = false
|
||||
|
||||
let loc_external_results res =
|
||||
let (loc, ofs) = calling_conventions 0 0 100 100 0 not_supported res in loc
|
||||
|
||||
|
|
@ -216,17 +192,6 @@ let max_register_pressure = function
|
|||
Iextcall(_, _) -> [| 6; 6 |]
|
||||
| _ -> [| 20; 15 |]
|
||||
|
||||
(* Reloading *)
|
||||
|
||||
let reload_test makereg round tst args = raise Use_default
|
||||
let reload_operation makereg round op args res = raise Use_default
|
||||
|
||||
(* No scheduling is needed, the assembler does it better than us. *)
|
||||
|
||||
let need_scheduling = false
|
||||
|
||||
let oper_latency _ = 1
|
||||
|
||||
(* Layout of the stack *)
|
||||
|
||||
let num_stack_slots = [| 0; 0 |]
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Reloading for the Mips *)
|
||||
|
||||
let fundecl f =
|
||||
(new Reloadgen.reload_generic ())#fundecl f
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Schedgen (* to create a dependency *)
|
||||
|
||||
(* No scheduling is needed for the Mips, the assembler
|
||||
does it better than us. *)
|
||||
|
||||
let fundecl f = f
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1997 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Instruction selection for the Mips processor *)
|
||||
|
||||
open Misc
|
||||
open Cmm
|
||||
open Reg
|
||||
open Arch
|
||||
open Mach
|
||||
|
||||
class selector () as self =
|
||||
|
||||
inherit Selectgen.selector_generic() as super
|
||||
|
||||
method is_immediate (n : int) = true
|
||||
|
||||
method select_addressing = function
|
||||
Cconst_symbol s ->
|
||||
(Ibased(s, 0), Ctuple [])
|
||||
| Cop(Cadda, [Cconst_symbol s; Cconst_int n]) ->
|
||||
(Ibased(s, n), Ctuple [])
|
||||
| Cop(Cadda, [arg; Cconst_int n]) ->
|
||||
(Iindexed n, arg)
|
||||
| Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) ->
|
||||
(Iindexed n, Cop(Cadda, [arg1; arg2]))
|
||||
| arg ->
|
||||
(Iindexed 0, arg)
|
||||
|
||||
end
|
||||
|
||||
let fundecl f = (new selector ())#emit_fundecl f
|
||||
|
|
@ -70,3 +70,22 @@ let print_specific_operation printreg op arg =
|
|||
| Imultsubf ->
|
||||
printreg arg.(0); print_string " *f "; printreg arg.(1);
|
||||
print_string " -f "; printreg arg.(2)
|
||||
|
||||
(* Distinguish between the PowerPC and the Power/RS6000 submodels *)
|
||||
|
||||
let powerpc =
|
||||
match Config.model with
|
||||
"ppc" -> true
|
||||
| "rs6000" -> false
|
||||
| _ -> Misc.fatal_error "wrong $(MODEL)"
|
||||
|
||||
(* Distinguish between the PowerOpen (AIX, MacOS) TOC-based,
|
||||
relative-addressing model and the SVR4 (Solaris, MkLinux)
|
||||
absolute-addressing model. *)
|
||||
|
||||
let toc =
|
||||
match Config.system with
|
||||
"aix" -> true
|
||||
| "elf" -> false
|
||||
| _ -> Misc.fatal_error "wrong $(SYSTEM)"
|
||||
|
||||
|
|
@ -19,110 +19,8 @@ open Reg
|
|||
open Arch
|
||||
open Mach
|
||||
|
||||
(* Distinguish between the PowerPC and the Power/RS6000 submodels *)
|
||||
|
||||
let powerpc =
|
||||
match Config.model with
|
||||
"ppc" -> true
|
||||
| "rs6000" -> false
|
||||
| _ -> fatal_error "wrong $(MODEL)"
|
||||
|
||||
(* Distinguish between the PowerOpen (AIX, MacOS) relative-addressing model
|
||||
and the SVR4 (Solaris, MkLinux) absolute-addressing model. *)
|
||||
|
||||
let svr4 =
|
||||
match Config.system with
|
||||
"aix" -> false
|
||||
| "elf" -> true
|
||||
| _ -> fatal_error "wrong $(SYSTEM)"
|
||||
|
||||
(* Exceptions raised to signal cases not handled here *)
|
||||
|
||||
exception Use_default
|
||||
|
||||
(* Recognition of addressing modes *)
|
||||
|
||||
type addressing_expr =
|
||||
Asymbol of string
|
||||
| Alinear of expression
|
||||
| Aadd of expression * expression
|
||||
|
||||
let rec select_addr = function
|
||||
Cconst_symbol s when svr4 -> (* don't recognize this mode in the TOC-based model *)
|
||||
(Asymbol s, 0)
|
||||
| Cop((Caddi | Cadda), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Caddi | Cadda), [Cconst_int m; arg]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Caddi | Cadda), [arg1; arg2]) ->
|
||||
begin match (select_addr arg1, select_addr arg2) with
|
||||
((Alinear e1, n1), (Alinear e2, n2)) ->
|
||||
(Aadd(e1, e2), n1 + n2)
|
||||
| _ ->
|
||||
(Aadd(arg1, arg2), 0)
|
||||
end
|
||||
| exp ->
|
||||
(Alinear exp, 0)
|
||||
|
||||
let select_addressing exp =
|
||||
match select_addr exp with
|
||||
(Asymbol s, d) ->
|
||||
(Ibased(s, d), Ctuple [])
|
||||
| (Alinear e, d) ->
|
||||
(Iindexed d, e)
|
||||
| (Aadd(e1, e2), d) ->
|
||||
if d = 0
|
||||
then (Iindexed2, Ctuple[e1; e2])
|
||||
else (Iindexed d, Cop(Cadda, [e1; e2]))
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
let select_logical op = function
|
||||
[arg; Cconst_int n] when n >= 0 & n <= 0xFFFF ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| [Cconst_int n; arg] when n >= 0 & n <= 0xFFFF ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| args ->
|
||||
(Iintop op, args)
|
||||
|
||||
let select_oper op args =
|
||||
match (op, args) with
|
||||
(* Prevent the recognition of (x / cst) and (x % cst) when cst is not
|
||||
a power of 2, which do not correspond to an instruction. *)
|
||||
(Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Idiv, n), [arg])
|
||||
| (Cdivi, _) ->
|
||||
(Iintop Idiv, args)
|
||||
| (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Imod, n), [arg])
|
||||
| (Cmodi, _) ->
|
||||
(Iintop Imod, args)
|
||||
(* The and, or and xor instructions have a different range of immediate
|
||||
operands than the other instructions *)
|
||||
| (Cand, _) -> select_logical Iand args
|
||||
| (Cor, _) -> select_logical Ior args
|
||||
| (Cxor, _) -> select_logical Ixor args
|
||||
(* intoffloat goes through a library function on the RS6000 *)
|
||||
| (Cintoffloat, _) when not powerpc ->
|
||||
(Iextcall("itrunc", false), args)
|
||||
(* Recognize mult-add and mult-sub instructions *)
|
||||
| (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) ->
|
||||
(Ispecific Imultaddf, [arg1; arg2; arg3])
|
||||
| (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) ->
|
||||
(Ispecific Imultaddf, [arg1; arg2; arg3])
|
||||
| (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) ->
|
||||
(Ispecific Imultsubf, [arg1; arg2; arg3])
|
||||
| _ ->
|
||||
raise Use_default
|
||||
|
||||
let select_store addr exp = raise Use_default
|
||||
|
||||
let select_push exp = fatal_error "Proc: select_push"
|
||||
|
||||
let pseudoregs_for_operation op arg res = raise Use_default
|
||||
|
||||
let is_immediate n = (n <= 32767) & (n >= -32768)
|
||||
|
||||
let word_addressed = false
|
||||
|
||||
(* Registers available for register allocation *)
|
||||
|
|
@ -219,7 +117,7 @@ let calling_conventions
|
|||
ofs := !ofs + size_float
|
||||
end
|
||||
done;
|
||||
let final_ofs = if not svr4 && !ofs > 0 then !ofs + 24 else !ofs in
|
||||
let final_ofs = if toc && !ofs > 0 then !ofs + 24 else !ofs in
|
||||
(loc, Misc.align final_ofs 8)
|
||||
(* Keep stack 8-aligned.
|
||||
Under PowerOpen, keep a free 24 byte linkage area at the bottom
|
||||
|
|
@ -279,9 +177,9 @@ let poweropen_external_conventions first_int last_int
|
|||
(loc, Misc.align !ofs 8) (* Keep stack 8-aligned *)
|
||||
|
||||
let loc_external_arguments arg =
|
||||
if svr4
|
||||
then calling_conventions 0 7 100 107 outgoing 8 arg
|
||||
else poweropen_external_conventions 0 7 100 112 arg
|
||||
if toc
|
||||
then poweropen_external_conventions 0 7 100 112 arg
|
||||
else calling_conventions 0 7 100 107 outgoing 8 arg
|
||||
|
||||
let extcall_use_push = false
|
||||
|
||||
|
|
@ -318,29 +216,6 @@ let max_register_pressure = function
|
|||
Iextcall(_, _) -> [| 15; 18 |]
|
||||
| _ -> [| 23; 30 |]
|
||||
|
||||
(* Reloading *)
|
||||
|
||||
let reload_test makereg round tst args = raise Use_default
|
||||
let reload_operation makereg round op args res = raise Use_default
|
||||
|
||||
(* Latencies (in cycles). Based roughly on the "common model". *)
|
||||
|
||||
let need_scheduling = true
|
||||
|
||||
let oper_latency = function
|
||||
Ireload -> 2
|
||||
| Iload(_, _) -> 2
|
||||
| Iconst_float _ -> 2 (* turned into a load *)
|
||||
| Iconst_symbol _ -> if svr4 then 1 else 2 (* turned into a load *)
|
||||
| Iintop Imul -> 9
|
||||
| Iintop_imm(Imul, _) -> 5
|
||||
| Iintop(Idiv | Imod) -> 36
|
||||
| Iaddf | Isubf -> 4
|
||||
| Imulf -> 5
|
||||
| Idivf -> 33
|
||||
| Ispecific(Imultaddf | Imultsubf) -> 5
|
||||
| _ -> 1
|
||||
|
||||
(* Layout of the stack *)
|
||||
|
||||
let num_stack_slots = [| 0; 0 |]
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Reloading for the PowerPC *)
|
||||
|
||||
let fundecl f =
|
||||
(new Reloadgen.reload_generic ())#fundecl f
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Instruction scheduling for the Power PC *)
|
||||
|
||||
open Arch
|
||||
open Mach
|
||||
|
||||
class scheduler () as self =
|
||||
|
||||
inherit Schedgen.scheduler_generic () as super
|
||||
|
||||
(* Latencies (in cycles). Based roughly on the "common model". *)
|
||||
|
||||
method oper_latency = function
|
||||
Ireload -> 2
|
||||
| Iload(_, _) -> 2
|
||||
| Iconst_float _ -> 2 (* turned into a load *)
|
||||
| Iconst_symbol _ -> if toc then 2 (* turned into a load *) else 1
|
||||
| Iintop Imul -> 9
|
||||
| Iintop_imm(Imul, _) -> 5
|
||||
| Iintop(Idiv | Imod) -> 36
|
||||
| Iaddf | Isubf -> 4
|
||||
| Imulf -> 5
|
||||
| Idivf -> 33
|
||||
| Ispecific(Imultaddf | Imultsubf) -> 5
|
||||
| _ -> 1
|
||||
|
||||
(* Issue cycles. Rough approximations. *)
|
||||
|
||||
method oper_issue_cycles = function
|
||||
Iconst_float _ | Iconst_symbol _ -> if toc then 1 else 2
|
||||
| Iload(_, Ibased(_, _)) -> 2
|
||||
| Istore(_, Ibased(_, _)) -> 2
|
||||
| Ialloc _ -> 4
|
||||
| Iintop(Imod) -> 40 (* assuming full stall *)
|
||||
| Iintop(Icomp _) -> 4
|
||||
| Iintop_imm(Idiv, _) -> 2
|
||||
| Iintop_imm(Imod, _) -> 4
|
||||
| Iintop_imm(Icomp _, _) -> 4
|
||||
| Ifloatofint -> 9
|
||||
| Iintoffloat -> 4
|
||||
| _ -> 1
|
||||
end
|
||||
|
||||
let fundecl f = (new scheduler ())#schedule_fundecl f
|
||||
|
||||
|
|
@ -0,0 +1,106 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1997 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Instruction selection for the Power PC processor *)
|
||||
|
||||
open Misc
|
||||
open Cmm
|
||||
open Reg
|
||||
open Arch
|
||||
open Mach
|
||||
|
||||
(* Recognition of addressing modes *)
|
||||
|
||||
type addressing_expr =
|
||||
Asymbol of string
|
||||
| Alinear of expression
|
||||
| Aadd of expression * expression
|
||||
|
||||
let rec select_addr = function
|
||||
Cconst_symbol s when not toc ->
|
||||
(* don't recognize this mode in the TOC-based model *)
|
||||
(Asymbol s, 0)
|
||||
| Cop((Caddi | Cadda), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Caddi | Cadda), [Cconst_int m; arg]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Caddi | Cadda), [arg1; arg2]) ->
|
||||
begin match (select_addr arg1, select_addr arg2) with
|
||||
((Alinear e1, n1), (Alinear e2, n2)) ->
|
||||
(Aadd(e1, e2), n1 + n2)
|
||||
| _ ->
|
||||
(Aadd(arg1, arg2), 0)
|
||||
end
|
||||
| exp ->
|
||||
(Alinear exp, 0)
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
class selector () as self =
|
||||
|
||||
inherit Selectgen.selector_generic() as super
|
||||
|
||||
method is_immediate n = (n <= 32767) & (n >= -32768)
|
||||
|
||||
method select_addressing exp =
|
||||
match select_addr exp with
|
||||
(Asymbol s, d) ->
|
||||
(Ibased(s, d), Ctuple [])
|
||||
| (Alinear e, d) ->
|
||||
(Iindexed d, e)
|
||||
| (Aadd(e1, e2), d) ->
|
||||
if d = 0
|
||||
then (Iindexed2, Ctuple[e1; e2])
|
||||
else (Iindexed d, Cop(Cadda, [e1; e2]))
|
||||
|
||||
method select_operation op args =
|
||||
match (op, args) with
|
||||
(* Prevent the recognition of (x / cst) and (x % cst) when cst is not
|
||||
a power of 2, which do not correspond to an instruction. *)
|
||||
(Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Idiv, n), [arg])
|
||||
| (Cdivi, _) ->
|
||||
(Iintop Idiv, args)
|
||||
| (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Imod, n), [arg])
|
||||
| (Cmodi, _) ->
|
||||
(Iintop Imod, args)
|
||||
(* The and, or and xor instructions have a different range of immediate
|
||||
operands than the other instructions *)
|
||||
| (Cand, _) -> self#select_logical Iand args
|
||||
| (Cor, _) -> self#select_logical Ior args
|
||||
| (Cxor, _) -> self#select_logical Ixor args
|
||||
(* intoffloat goes through a library function on the RS6000 *)
|
||||
| (Cintoffloat, _) when not powerpc ->
|
||||
(Iextcall("itrunc", false), args)
|
||||
(* Recognize mult-add and mult-sub instructions *)
|
||||
| (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) ->
|
||||
(Ispecific Imultaddf, [arg1; arg2; arg3])
|
||||
| (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) ->
|
||||
(Ispecific Imultaddf, [arg1; arg2; arg3])
|
||||
| (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) ->
|
||||
(Ispecific Imultsubf, [arg1; arg2; arg3])
|
||||
| _ ->
|
||||
super#select_operation op args
|
||||
|
||||
method select_logical op = function
|
||||
[arg; Cconst_int n] when n >= 0 & n <= 0xFFFF ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| [Cconst_int n; arg] when n >= 0 & n <= 0xFFFF ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| args ->
|
||||
(Iintop op, args)
|
||||
|
||||
end
|
||||
|
||||
let fundecl f = (new selector ())#emit_fundecl f
|
||||
|
|
@ -13,24 +13,7 @@
|
|||
|
||||
(* Processor descriptions *)
|
||||
|
||||
(* The Use_default exception is raised by the selection and reloading
|
||||
functions to signal cases they don't handle *)
|
||||
exception Use_default
|
||||
|
||||
(* Instruction selection *)
|
||||
val select_addressing:
|
||||
Cmm.expression -> Arch.addressing_mode * Cmm.expression
|
||||
val select_oper:
|
||||
Cmm.operation -> Cmm.expression list ->
|
||||
Mach.operation * Cmm.expression list
|
||||
val select_store:
|
||||
Arch.addressing_mode -> Cmm.expression -> Mach.operation * Cmm.expression
|
||||
val select_push:
|
||||
Cmm.expression -> Mach.operation * Cmm.expression
|
||||
val pseudoregs_for_operation:
|
||||
Mach.operation -> Reg.t array -> Reg.t array ->
|
||||
Reg.t array * Reg.t array * bool
|
||||
val is_immediate: int -> bool
|
||||
val word_addressed: bool
|
||||
|
||||
(* Registers available for register allocation *)
|
||||
|
|
@ -48,11 +31,9 @@ val loc_results: Reg.t array -> Reg.t array
|
|||
val loc_parameters: Reg.t array -> Reg.t array
|
||||
val loc_external_arguments: Reg.t array -> Reg.t array * int
|
||||
val loc_external_results: Reg.t array -> Reg.t array
|
||||
val extcall_use_push : bool
|
||||
val loc_exn_bucket: Reg.t
|
||||
|
||||
(* Maximal register pressures for pre-spilling *)
|
||||
|
||||
val safe_register_pressure: Mach.operation -> int
|
||||
val max_register_pressure: Mach.operation -> int array
|
||||
|
||||
|
|
@ -60,17 +41,6 @@ val max_register_pressure: Mach.operation -> int array
|
|||
val destroyed_at_oper: Mach.instruction_desc -> Reg.t array
|
||||
val destroyed_at_raise: Reg.t array
|
||||
|
||||
(* Reloading of instruction arguments, storing of instruction results *)
|
||||
val reload_test:
|
||||
(Reg.t -> Reg.t) -> int -> Mach.test -> Reg.t array -> Reg.t array
|
||||
val reload_operation:
|
||||
(Reg.t -> Reg.t) -> int -> Mach.operation ->
|
||||
Reg.t array -> Reg.t array -> Reg.t array * Reg.t array
|
||||
|
||||
(* Latency info for instruction scheduling *)
|
||||
val need_scheduling: bool
|
||||
val oper_latency: Mach.operation -> int
|
||||
|
||||
(* Info for laying out the stack frame *)
|
||||
val num_stack_slots: int array
|
||||
val contains_calls: bool ref
|
||||
|
|
|
|||
|
|
@ -1,434 +0,0 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Description of the Intel 386 processor *)
|
||||
|
||||
open Misc
|
||||
open Arch
|
||||
open Format
|
||||
open Cmm
|
||||
open Reg
|
||||
open Mach
|
||||
|
||||
(* Registers available for register allocation *)
|
||||
|
||||
(* Register map:
|
||||
eax 0 eax - edi: function arguments and results
|
||||
ebx 1 eax: C function results
|
||||
ecx 2 ebx, esi, edi, ebp: preserved by C
|
||||
edx 3
|
||||
esi 4
|
||||
edi 5
|
||||
ebp 6
|
||||
|
||||
tos 100 top of floating-point stack. *)
|
||||
|
||||
let int_reg_name =
|
||||
[| "%eax"; "%ebx"; "%ecx"; "%edx"; "%esi"; "%edi"; "%ebp" |]
|
||||
|
||||
let float_reg_name =
|
||||
[| "%tos" |]
|
||||
|
||||
let num_register_classes = 2
|
||||
|
||||
let register_class r =
|
||||
match r.typ with
|
||||
Int -> 0
|
||||
| Addr -> 0
|
||||
| Float -> 1
|
||||
|
||||
let num_available_registers = [| 7; 0 |]
|
||||
|
||||
let first_available_register = [| 0; 100 |]
|
||||
|
||||
let register_name r =
|
||||
if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
|
||||
|
||||
(* There is little scheduling, and some operations are more compact
|
||||
when their argument is %eax. *)
|
||||
|
||||
let rotate_registers = false
|
||||
|
||||
(* Representation of hard registers by pseudo-registers *)
|
||||
|
||||
let hard_int_reg =
|
||||
let v = Array.create 7 Reg.dummy in
|
||||
for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done;
|
||||
v
|
||||
|
||||
let hard_float_reg = [| Reg.at_location Float (Reg 100) |]
|
||||
|
||||
let all_phys_regs =
|
||||
Array.append hard_int_reg hard_float_reg
|
||||
|
||||
let phys_reg n =
|
||||
if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
|
||||
|
||||
let stack_slot slot ty =
|
||||
Reg.at_location ty (Stack slot)
|
||||
|
||||
let eax = phys_reg 0
|
||||
let ecx = phys_reg 2
|
||||
let edx = phys_reg 3
|
||||
let tos = phys_reg 100
|
||||
|
||||
(* Exceptions raised to signal cases not handled here *)
|
||||
|
||||
exception Use_default
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
(* Auxiliary for recognizing addressing modes *)
|
||||
|
||||
type addressing_expr =
|
||||
Asymbol of string
|
||||
| Alinear of expression
|
||||
| Aadd of expression * expression
|
||||
| Ascale of expression * int
|
||||
| Ascaledadd of expression * expression * int
|
||||
|
||||
let rec select_addr exp =
|
||||
match exp with
|
||||
Cconst_symbol s ->
|
||||
(Asymbol s, 0)
|
||||
| Cop((Caddi | Cadda), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Csubi | Csuba), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n - m)
|
||||
| Cop((Caddi | Cadda), [Cconst_int m; arg]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, mult), n * mult)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, mult), n * mult)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop((Caddi | Cadda), [arg1; arg2]) ->
|
||||
begin match (select_addr arg1, select_addr arg2) with
|
||||
((Alinear e1, n1), (Alinear e2, n2)) ->
|
||||
(Aadd(e1, e2), n1 + n2)
|
||||
| ((Alinear e1, n1), (Ascale(e2, scale), n2)) ->
|
||||
(Ascaledadd(e1, e2, scale), n1 + n2)
|
||||
| ((Ascale(e1, scale), n1), (Alinear e2, n2)) ->
|
||||
(Ascaledadd(e2, e1, scale), n1 + n2)
|
||||
| (_, (Ascale(e2, scale), n2)) ->
|
||||
(Ascaledadd(arg1, e2, scale), n2)
|
||||
| ((Ascale(e1, scale), n1), _) ->
|
||||
(Ascaledadd(arg2, e1, scale), n1)
|
||||
| _ ->
|
||||
(Aadd(arg1, arg2), 0)
|
||||
end
|
||||
| arg ->
|
||||
(Alinear arg, 0)
|
||||
|
||||
let select_addressing exp =
|
||||
match select_addr exp with
|
||||
(Asymbol s, d) ->
|
||||
(Ibased(s, d), Ctuple [])
|
||||
| (Alinear e, d) ->
|
||||
(Iindexed d, e)
|
||||
| (Aadd(e1, e2), d) ->
|
||||
(Iindexed2 d, Ctuple[e1; e2])
|
||||
| (Ascale(e, scale), d) ->
|
||||
(Iscaled(scale, d), e)
|
||||
| (Ascaledadd(e1, e2, scale), d) ->
|
||||
(Iindexed2scaled(scale, d), Ctuple[e1; e2])
|
||||
|
||||
(* Estimate number of float temporaries needed to evaluate expression
|
||||
(Ershov's algorithm) *)
|
||||
|
||||
let rec float_needs = function
|
||||
Cop((Caddf | Csubf | Cmulf | Cdivf), [arg1; arg2]) ->
|
||||
let n1 = float_needs arg1 in
|
||||
let n2 = float_needs arg2 in
|
||||
if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2
|
||||
| _ ->
|
||||
1
|
||||
|
||||
(* Recognize float arithmetic with mem *)
|
||||
|
||||
let select_floatarith regular_op reversed_op mem_op mem_rev_op args =
|
||||
match args with
|
||||
[arg1; Cop(Cload _, [loc2])] ->
|
||||
let (addr, arg2) = select_addressing loc2 in
|
||||
(Ispecific(Ifloatarithmem(mem_op, addr)), [arg1; arg2])
|
||||
| [Cop(Cload _, [loc1]); arg2] ->
|
||||
let (addr, arg1) = select_addressing loc1 in
|
||||
(Ispecific(Ifloatarithmem(mem_rev_op, addr)), [arg2; arg1])
|
||||
| [arg1; arg2] ->
|
||||
(* Evaluate bigger subexpression first to minimize stack usage.
|
||||
Because of right-to-left evaluation, rightmost arg is evaluated
|
||||
first *)
|
||||
if float_needs arg1 <= float_needs arg2
|
||||
then (regular_op, [arg1; arg2])
|
||||
else (reversed_op, [arg2; arg1])
|
||||
| _ ->
|
||||
fatal_error "Proc_i386: select_floatarith"
|
||||
|
||||
(* Main instruction selection functions *)
|
||||
|
||||
let select_oper op args =
|
||||
match op with
|
||||
(* Recognize the LEA instruction *)
|
||||
Caddi | Cadda | Csubi | Csuba ->
|
||||
begin match select_addressing (Cop(op, args)) with
|
||||
(Iindexed d, _) -> raise Use_default
|
||||
| (Iindexed2 0, _) -> raise Use_default
|
||||
| (addr, arg) -> (Ispecific(Ilea addr), [arg])
|
||||
end
|
||||
(* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *)
|
||||
| Cdivi ->
|
||||
begin match args with
|
||||
[arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Idiv, n), [arg1])
|
||||
| _ -> (Iintop Idiv, args)
|
||||
end
|
||||
| Cmodi ->
|
||||
begin match args with
|
||||
[arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Imod, n), [arg1])
|
||||
| _ -> (Iintop Imod, args)
|
||||
end
|
||||
(* Recognize float arithmetic with memory.
|
||||
In passing, apply Ershov's algorithm to reduce stack usage *)
|
||||
| Caddf ->
|
||||
select_floatarith Iaddf Iaddf Ifloatadd Ifloatadd args
|
||||
| Csubf ->
|
||||
select_floatarith Isubf (Ispecific Isubfrev) Ifloatsub Ifloatsubrev args
|
||||
| Cmulf ->
|
||||
select_floatarith Imulf Imulf Ifloatmul Ifloatmul args
|
||||
| Cdivf ->
|
||||
select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev args
|
||||
(* Recognize store instructions *)
|
||||
| Cstore ->
|
||||
begin match args with
|
||||
[loc; Cconst_int n] ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Istore_int(n, addr)), [arg])
|
||||
| [loc; Cconst_pointer n] ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Istore_int(n, addr)), [arg])
|
||||
| [loc; Cconst_symbol s] ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Istore_symbol(s, addr)), [arg])
|
||||
| [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])]
|
||||
when loc = loc' ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Ioffset_loc(n, addr)), [arg])
|
||||
| _ ->
|
||||
raise Use_default
|
||||
end
|
||||
| _ -> raise Use_default
|
||||
|
||||
let select_store addr exp =
|
||||
match exp with
|
||||
Cconst_int n -> (Ispecific(Istore_int(n, addr)), Ctuple [])
|
||||
| Cconst_pointer n -> (Ispecific(Istore_int(n, addr)), Ctuple [])
|
||||
| Cconst_symbol s -> (Ispecific(Istore_symbol(s, addr)), Ctuple [])
|
||||
| _ -> raise Use_default
|
||||
|
||||
let select_push exp =
|
||||
match exp with
|
||||
Cconst_int n -> (Ispecific(Ipush_int n), Ctuple [])
|
||||
| Cconst_pointer n -> (Ispecific(Ipush_int n), Ctuple [])
|
||||
| Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
|
||||
| Cop(Cload ty, [loc]) when ty = typ_float ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Ipush_load_float addr), arg)
|
||||
| Cop(Cload ty, [loc]) when ty = typ_addr or ty = typ_int ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Ipush_load addr), arg)
|
||||
| _ -> (Ispecific(Ipush), exp)
|
||||
|
||||
let pseudoregs_for_operation op arg res =
|
||||
match op with
|
||||
(* Two-address binary operations *)
|
||||
Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) ->
|
||||
([|res.(0); arg.(1)|], res, false)
|
||||
(* Two-address unary operations *)
|
||||
| Iintop_imm((Iadd|Isub|Imul|Idiv|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) ->
|
||||
(res, res, false)
|
||||
(* For shifts with variable shift count, second arg must be in ecx *)
|
||||
| Iintop(Ilsl|Ilsr|Iasr) ->
|
||||
([|res.(0); ecx|], res, false)
|
||||
(* For div and mod, first arg must be in eax, edx is clobbered,
|
||||
and result is in eax or edx respectively.
|
||||
Keep it simple, just force second argument in ecx. *)
|
||||
| Iintop(Idiv) ->
|
||||
([| eax; ecx |], [| eax |], true)
|
||||
| Iintop(Imod) ->
|
||||
([| eax; ecx |], [| edx |], true)
|
||||
(* For mod with immediate operand, arg must not be in eax.
|
||||
Keep it simple, force it in edx. *)
|
||||
| Iintop_imm(Imod, _) ->
|
||||
([| edx |], [| edx |], true)
|
||||
(* For floating-point operations, the result is always left at the
|
||||
top of the floating-point stack *)
|
||||
| Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
|
||||
| Ifloatofint |Ispecific(Isubfrev | Idivfrev | Ifloatarithmem(_, _)) ->
|
||||
(arg, [| tos |], false) (* don't move it immediately *)
|
||||
(* Same for a floating-point load *)
|
||||
| Iload(Word, addr) when res.(0).typ = Float ->
|
||||
(arg, [| tos |], false)
|
||||
(* For storing a byte, the argument must be in eax...edx.
|
||||
For storing a halfword, any reg is ok.
|
||||
Keep it simple, just force it to be in edx in both cases. *)
|
||||
| Istore(Word, addr) -> raise Use_default
|
||||
| Istore(chunk, addr) ->
|
||||
let newarg = Array.copy arg in
|
||||
newarg.(0) <- edx;
|
||||
(newarg, res, false)
|
||||
(* Other instructions are more or less regular *)
|
||||
| _ -> raise Use_default
|
||||
|
||||
let is_immediate (n: int) = true
|
||||
|
||||
let word_addressed = false
|
||||
|
||||
(* Calling conventions *)
|
||||
|
||||
let calling_conventions first_int last_int first_float last_float make_stack
|
||||
arg =
|
||||
let loc = Array.create (Array.length arg) Reg.dummy in
|
||||
let int = ref first_int in
|
||||
let float = ref first_float in
|
||||
let ofs = ref 0 in
|
||||
for i = 0 to Array.length arg - 1 do
|
||||
match arg.(i).typ with
|
||||
Int | Addr as ty ->
|
||||
if !int <= last_int then begin
|
||||
loc.(i) <- phys_reg !int;
|
||||
incr int
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) ty;
|
||||
ofs := !ofs + size_int
|
||||
end
|
||||
| Float ->
|
||||
if !float <= last_float then begin
|
||||
loc.(i) <- phys_reg !float;
|
||||
incr float
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) Float;
|
||||
ofs := !ofs + size_float
|
||||
end
|
||||
done;
|
||||
(loc, !ofs)
|
||||
|
||||
let incoming ofs = Incoming ofs
|
||||
let outgoing ofs = Outgoing ofs
|
||||
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
|
||||
|
||||
let loc_arguments arg =
|
||||
calling_conventions 0 5 100 99 outgoing arg
|
||||
let loc_parameters arg =
|
||||
let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc
|
||||
let loc_results res =
|
||||
let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc
|
||||
let extcall_use_push = true
|
||||
let loc_external_arguments arg =
|
||||
fatal_error "Proc.loc_external_arguments"
|
||||
let loc_external_results res =
|
||||
let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
|
||||
|
||||
let loc_exn_bucket = eax
|
||||
|
||||
(* Registers destroyed by operations *)
|
||||
|
||||
let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *)
|
||||
Array.of_list(List.map phys_reg [0;2;3])
|
||||
|
||||
let destroyed_at_oper = function
|
||||
Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
|
||||
| Iop(Iextcall(_, false)) -> destroyed_at_c_call
|
||||
| Iop(Iintop(Idiv | Imod)) -> [| eax; edx |]
|
||||
| Iop(Iintop_imm(Imod, _)) -> [| eax |]
|
||||
| Iop(Ialloc _) -> [| eax |]
|
||||
| Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |]
|
||||
| Iop(Iintoffloat) -> [| eax |]
|
||||
| Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |]
|
||||
| _ -> [||]
|
||||
|
||||
let destroyed_at_raise = all_phys_regs
|
||||
|
||||
(* Maximal register pressure *)
|
||||
|
||||
let safe_register_pressure op = 4
|
||||
|
||||
let max_register_pressure = function
|
||||
Iextcall(_, _) -> [| 4; max_int |]
|
||||
| Iintop(Idiv | Imod) -> [| 5; max_int |]
|
||||
| Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) |
|
||||
Iintoffloat -> [| 6; max_int |]
|
||||
| _ -> [|7; max_int |]
|
||||
|
||||
(* Reloading of instruction arguments, storing of instruction results. *)
|
||||
|
||||
let stackp r =
|
||||
match r.loc with
|
||||
Stack _ -> true
|
||||
| _ -> false
|
||||
|
||||
let reload_test makereg round tst arg =
|
||||
match tst with
|
||||
Iinttest cmp ->
|
||||
if stackp arg.(0) & stackp arg.(1)
|
||||
then [| makereg arg.(0); arg.(1) |]
|
||||
else arg
|
||||
| _ -> arg
|
||||
|
||||
(* Since #floatregs = 0, pseudoregs of type float will never be reloaded.
|
||||
Hence there is no need to make special cases for
|
||||
floating-point operations. *)
|
||||
|
||||
let reload_operation makereg round op arg res =
|
||||
match op with
|
||||
Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor|Icomp _|Icheckbound) ->
|
||||
(* One of the two arguments can reside in the stack *)
|
||||
if stackp arg.(0) & stackp arg.(1)
|
||||
then ([|arg.(0); makereg arg.(1)|], res)
|
||||
else (arg, res)
|
||||
| Iintop(Ilsl|Ilsr|Iasr) | Iintop_imm(_, _) | Ifloatofint | Iintoffloat |
|
||||
Ispecific(Ipush) ->
|
||||
(* The argument(s) can be either in register or on stack *)
|
||||
(arg, res)
|
||||
| _ -> (* Other operations: all args and results in registers *)
|
||||
raise Use_default
|
||||
|
||||
(* Scheduling is turned off because our model does not fit the 486
|
||||
nor Pentium very well. In particular, it messes up with the
|
||||
float reg stack. The Pentium Pro schedules at run-time much better
|
||||
than what we could do. *)
|
||||
|
||||
let need_scheduling = false
|
||||
|
||||
let oper_latency _ = 0
|
||||
|
||||
(* Layout of the stack frame *)
|
||||
|
||||
let num_stack_slots = [| 0; 0 |]
|
||||
let contains_calls = ref false
|
||||
|
||||
(* Calling the assembler *)
|
||||
|
||||
let assemble_file infile outfile =
|
||||
Ccomp.command ("as -o " ^ outfile ^ " " ^ infile)
|
||||
|
||||
|
|
@ -1,436 +0,0 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Description of the Intel 386 processor, for Windows NT *)
|
||||
|
||||
open Misc
|
||||
open Arch
|
||||
open Format
|
||||
open Cmm
|
||||
open Reg
|
||||
open Mach
|
||||
|
||||
(* Registers available for register allocation *)
|
||||
|
||||
(* Register map:
|
||||
eax 0 eax - edi: function arguments and results
|
||||
ebx 1 eax: C function results
|
||||
ecx 2 ebx, esi, edi, ebp: preserved by C
|
||||
edx 3
|
||||
esi 4
|
||||
edi 5
|
||||
ebp 6
|
||||
|
||||
tos 100 top of floating-point stack. *)
|
||||
|
||||
let int_reg_name =
|
||||
[| "eax"; "ebx"; "ecx"; "edx"; "esi"; "edi"; "ebp" |]
|
||||
|
||||
let float_reg_name =
|
||||
[| "tos" |]
|
||||
|
||||
let num_register_classes = 2
|
||||
|
||||
let register_class r =
|
||||
match r.typ with
|
||||
Int -> 0
|
||||
| Addr -> 0
|
||||
| Float -> 1
|
||||
|
||||
let num_available_registers = [| 7; 0 |]
|
||||
|
||||
let first_available_register = [| 0; 100 |]
|
||||
|
||||
let register_name r =
|
||||
if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
|
||||
|
||||
(* There is little scheduling, and some operations are more compact
|
||||
when their argument is %eax. *)
|
||||
|
||||
let rotate_registers = false
|
||||
|
||||
(* Representation of hard registers by pseudo-registers *)
|
||||
|
||||
let hard_int_reg =
|
||||
let v = Array.create 7 Reg.dummy in
|
||||
for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done;
|
||||
v
|
||||
|
||||
let hard_float_reg = [| Reg.at_location Float (Reg 100) |]
|
||||
|
||||
let all_phys_regs =
|
||||
Array.append hard_int_reg hard_float_reg
|
||||
|
||||
let phys_reg n =
|
||||
if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
|
||||
|
||||
let stack_slot slot ty =
|
||||
Reg.at_location ty (Stack slot)
|
||||
|
||||
let eax = phys_reg 0
|
||||
let ecx = phys_reg 2
|
||||
let edx = phys_reg 3
|
||||
let tos = phys_reg 100
|
||||
|
||||
(* Exceptions raised to signal cases not handled here *)
|
||||
|
||||
exception Use_default
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
(* Auxiliary for recognizing addressing modes *)
|
||||
|
||||
type addressing_expr =
|
||||
Asymbol of string
|
||||
| Alinear of expression
|
||||
| Aadd of expression * expression
|
||||
| Ascale of expression * int
|
||||
| Ascaledadd of expression * expression * int
|
||||
|
||||
let rec select_addr exp =
|
||||
match exp with
|
||||
Cconst_symbol s ->
|
||||
(Asymbol s, 0)
|
||||
| Cop((Caddi | Cadda), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Csubi | Csuba), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n - m)
|
||||
| Cop((Caddi | Cadda), [Cconst_int m; arg]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, mult), n * mult)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, mult), n * mult)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop((Caddi | Cadda), [arg1; arg2]) ->
|
||||
begin match (select_addr arg1, select_addr arg2) with
|
||||
((Alinear e1, n1), (Alinear e2, n2)) ->
|
||||
(Aadd(e1, e2), n1 + n2)
|
||||
| ((Alinear e1, n1), (Ascale(e2, scale), n2)) ->
|
||||
(Ascaledadd(e1, e2, scale), n1 + n2)
|
||||
| ((Ascale(e1, scale), n1), (Alinear e2, n2)) ->
|
||||
(Ascaledadd(e2, e1, scale), n1 + n2)
|
||||
| (_, (Ascale(e2, scale), n2)) ->
|
||||
(Ascaledadd(arg1, e2, scale), n2)
|
||||
| ((Ascale(e1, scale), n1), _) ->
|
||||
(Ascaledadd(arg2, e1, scale), n1)
|
||||
| _ ->
|
||||
(Aadd(arg1, arg2), 0)
|
||||
end
|
||||
| arg ->
|
||||
(Alinear arg, 0)
|
||||
|
||||
let select_addressing exp =
|
||||
match select_addr exp with
|
||||
(Asymbol s, d) ->
|
||||
(Ibased(s, d), Ctuple [])
|
||||
| (Alinear e, d) ->
|
||||
(Iindexed d, e)
|
||||
| (Aadd(e1, e2), d) ->
|
||||
(Iindexed2 d, Ctuple[e1; e2])
|
||||
| (Ascale(e, scale), d) ->
|
||||
(Iscaled(scale, d), e)
|
||||
| (Ascaledadd(e1, e2, scale), d) ->
|
||||
(Iindexed2scaled(scale, d), Ctuple[e1; e2])
|
||||
|
||||
(* Estimate number of float temporaries needed to evaluate expression
|
||||
(Ershov's algorithm) *)
|
||||
|
||||
let rec float_needs = function
|
||||
Cop((Caddf | Csubf | Cmulf | Cdivf), [arg1; arg2]) ->
|
||||
let n1 = float_needs arg1 in
|
||||
let n2 = float_needs arg2 in
|
||||
if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2
|
||||
| _ ->
|
||||
1
|
||||
|
||||
(* Recognize float arithmetic with mem *)
|
||||
|
||||
let select_floatarith regular_op reversed_op mem_op mem_rev_op args =
|
||||
match args with
|
||||
[arg1; Cop(Cload _, [loc2])] ->
|
||||
let (addr, arg2) = select_addressing loc2 in
|
||||
(Ispecific(Ifloatarithmem(mem_op, addr)), [arg1; arg2])
|
||||
| [Cop(Cload _, [loc1]); arg2] ->
|
||||
let (addr, arg1) = select_addressing loc1 in
|
||||
(Ispecific(Ifloatarithmem(mem_rev_op, addr)), [arg2; arg1])
|
||||
| [arg1; arg2] ->
|
||||
(* Evaluate bigger subexpression first to minimize stack usage.
|
||||
Because of right-to-left evaluation, rightmost arg is evaluated
|
||||
first *)
|
||||
if float_needs arg1 <= float_needs arg2
|
||||
then (regular_op, [arg1; arg2])
|
||||
else (reversed_op, [arg2; arg1])
|
||||
| _ ->
|
||||
fatal_error "Proc_i386: select_floatarith"
|
||||
|
||||
(* Main instruction selection functions *)
|
||||
|
||||
let select_oper op args =
|
||||
match op with
|
||||
(* Recognize the LEA instruction *)
|
||||
Caddi | Cadda | Csubi | Csuba ->
|
||||
begin match select_addressing (Cop(op, args)) with
|
||||
(Iindexed d, _) -> raise Use_default
|
||||
| (Iindexed2 0, _) -> raise Use_default
|
||||
| (addr, arg) -> (Ispecific(Ilea addr), [arg])
|
||||
end
|
||||
(* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *)
|
||||
| Cdivi ->
|
||||
begin match args with
|
||||
[arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Idiv, n), [arg1])
|
||||
| _ -> (Iintop Idiv, args)
|
||||
end
|
||||
| Cmodi ->
|
||||
begin match args with
|
||||
[arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Imod, n), [arg1])
|
||||
| _ -> (Iintop Imod, args)
|
||||
end
|
||||
(* Recognize float arithmetic with memory.
|
||||
In passing, apply Ershov's algorithm to reduce stack usage *)
|
||||
| Caddf ->
|
||||
select_floatarith Iaddf Iaddf Ifloatadd Ifloatadd args
|
||||
| Csubf ->
|
||||
select_floatarith Isubf (Ispecific Isubfrev) Ifloatsub Ifloatsubrev args
|
||||
| Cmulf ->
|
||||
select_floatarith Imulf Imulf Ifloatmul Ifloatmul args
|
||||
| Cdivf ->
|
||||
select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev args
|
||||
(* Recognize store instructions *)
|
||||
| Cstore ->
|
||||
begin match args with
|
||||
[loc; Cconst_int n] ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Istore_int(n, addr)), [arg])
|
||||
| [loc; Cconst_pointer n] ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Istore_int(n, addr)), [arg])
|
||||
| [loc; Cconst_symbol s] ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Istore_symbol(s, addr)), [arg])
|
||||
| [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])]
|
||||
when loc = loc' ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Ioffset_loc(n, addr)), [arg])
|
||||
| _ ->
|
||||
raise Use_default
|
||||
end
|
||||
| _ -> raise Use_default
|
||||
|
||||
let select_store addr exp =
|
||||
match exp with
|
||||
Cconst_int n -> (Ispecific(Istore_int(n, addr)), Ctuple [])
|
||||
| Cconst_pointer n -> (Ispecific(Istore_int(n, addr)), Ctuple [])
|
||||
| Cconst_symbol s -> (Ispecific(Istore_symbol(s, addr)), Ctuple [])
|
||||
| _ -> raise Use_default
|
||||
|
||||
let select_push exp =
|
||||
match exp with
|
||||
Cconst_int n -> (Ispecific(Ipush_int n), Ctuple [])
|
||||
| Cconst_pointer n -> (Ispecific(Ipush_int n), Ctuple [])
|
||||
| Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
|
||||
| Cop(Cload ty, [loc]) when ty = typ_float ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Ipush_load_float addr), arg)
|
||||
| Cop(Cload ty, [loc]) when ty = typ_addr or ty = typ_int ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Ipush_load addr), arg)
|
||||
| _ -> (Ispecific(Ipush), exp)
|
||||
|
||||
let pseudoregs_for_operation op arg res =
|
||||
match op with
|
||||
(* Two-address binary operations *)
|
||||
Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) ->
|
||||
([|res.(0); arg.(1)|], res, false)
|
||||
(* Two-address unary operations *)
|
||||
| Iintop_imm((Iadd|Isub|Imul|Idiv|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) ->
|
||||
(res, res, false)
|
||||
(* For shifts with variable shift count, second arg must be in ecx *)
|
||||
| Iintop(Ilsl|Ilsr|Iasr) ->
|
||||
([|res.(0); ecx|], res, false)
|
||||
(* For div and mod, first arg must be in eax, edx is clobbered,
|
||||
and result is in eax or edx respectively.
|
||||
Keep it simple, just force second argument in ecx. *)
|
||||
| Iintop(Idiv) ->
|
||||
([| eax; ecx |], [| eax |], true)
|
||||
| Iintop(Imod) ->
|
||||
([| eax; ecx |], [| edx |], true)
|
||||
(* For mod with immediate operand, arg must not be in eax.
|
||||
Keep it simple, force it in edx. *)
|
||||
| Iintop_imm(Imod, _) ->
|
||||
([| edx |], [| edx |], true)
|
||||
(* For floating-point operations, the result is always left at the
|
||||
top of the floating-point stack *)
|
||||
| Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
|
||||
| Ifloatofint |Ispecific(Isubfrev | Idivfrev | Ifloatarithmem(_, _)) ->
|
||||
(arg, [| tos |], false) (* don't move it immediately *)
|
||||
(* Same for a floating-point load *)
|
||||
| Iload(Word, addr) when res.(0).typ = Float ->
|
||||
(arg, [| tos |], false)
|
||||
(* For storing a byte, the argument must be in eax...edx.
|
||||
For storing a halfword, any reg is ok.
|
||||
Keep it simple, just force it to be in edx in both cases. *)
|
||||
| Istore(Word, addr) -> raise Use_default
|
||||
| Istore(chunk, addr) ->
|
||||
let newarg = Array.copy arg in
|
||||
newarg.(0) <- edx;
|
||||
(newarg, res, false)
|
||||
(* Other instructions are more or less regular *)
|
||||
| _ -> raise Use_default
|
||||
|
||||
let is_immediate (n: int) = true
|
||||
|
||||
let word_addressed = false
|
||||
|
||||
(* Calling conventions *)
|
||||
|
||||
let calling_conventions first_int last_int first_float last_float make_stack
|
||||
arg =
|
||||
let loc = Array.create (Array.length arg) Reg.dummy in
|
||||
let int = ref first_int in
|
||||
let float = ref first_float in
|
||||
let ofs = ref 0 in
|
||||
for i = 0 to Array.length arg - 1 do
|
||||
match arg.(i).typ with
|
||||
Int | Addr as ty ->
|
||||
if !int <= last_int then begin
|
||||
loc.(i) <- phys_reg !int;
|
||||
incr int
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) ty;
|
||||
ofs := !ofs + size_int
|
||||
end
|
||||
| Float ->
|
||||
if !float <= last_float then begin
|
||||
loc.(i) <- phys_reg !float;
|
||||
incr float
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) Float;
|
||||
ofs := !ofs + size_float
|
||||
end
|
||||
done;
|
||||
(loc, !ofs)
|
||||
|
||||
let incoming ofs = Incoming ofs
|
||||
let outgoing ofs = Outgoing ofs
|
||||
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
|
||||
|
||||
let loc_arguments arg =
|
||||
calling_conventions 0 5 100 99 outgoing arg
|
||||
let loc_parameters arg =
|
||||
let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc
|
||||
let loc_results res =
|
||||
let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc
|
||||
let extcall_use_push = true
|
||||
let loc_external_arguments arg =
|
||||
fatal_error "Proc.loc_external_arguments"
|
||||
let loc_external_results res =
|
||||
let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
|
||||
|
||||
let loc_exn_bucket = eax
|
||||
|
||||
(* Registers destroyed by operations *)
|
||||
|
||||
let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *)
|
||||
Array.of_list(List.map phys_reg [0;2;3])
|
||||
|
||||
let destroyed_at_oper = function
|
||||
Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
|
||||
| Iop(Iextcall(_, false)) -> destroyed_at_c_call
|
||||
| Iop(Iintop(Idiv | Imod)) -> [| eax; edx |]
|
||||
| Iop(Iintop_imm(Imod, _)) -> [| eax |]
|
||||
| Iop(Ialloc _) -> [| eax |]
|
||||
| Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |]
|
||||
| Iop(Iintoffloat) -> [| eax |]
|
||||
| Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |]
|
||||
| _ -> [||]
|
||||
|
||||
let destroyed_at_raise = all_phys_regs
|
||||
|
||||
(* Maximal register pressure *)
|
||||
|
||||
let safe_register_pressure op = 4
|
||||
|
||||
let max_register_pressure = function
|
||||
Iextcall(_, _) -> [| 4; max_int |]
|
||||
| Iintop(Idiv | Imod) -> [| 5; max_int |]
|
||||
| Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) |
|
||||
Iintoffloat -> [| 6; max_int |]
|
||||
| _ -> [|7; max_int |]
|
||||
|
||||
(* Reloading of instruction arguments, storing of instruction results *)
|
||||
|
||||
let stackp r =
|
||||
match r.loc with
|
||||
Stack _ -> true
|
||||
| _ -> false
|
||||
|
||||
let reload_test makereg round tst arg =
|
||||
match tst with
|
||||
Iinttest cmp ->
|
||||
if stackp arg.(0) & stackp arg.(1)
|
||||
then [| makereg arg.(0); arg.(1) |]
|
||||
else arg
|
||||
| _ -> arg
|
||||
|
||||
(* Since #floatregs = 0, pseudoregs of type float will never be reloaded.
|
||||
Hence there is no need to make special cases for
|
||||
floating-point operations. *)
|
||||
|
||||
let reload_operation makereg round op arg res =
|
||||
match op with
|
||||
Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor|Icomp _|Icheckbound) ->
|
||||
(* One of the two arguments can reside in the stack *)
|
||||
if stackp arg.(0) & stackp arg.(1)
|
||||
then ([|arg.(0); makereg arg.(1)|], res)
|
||||
else (arg, res)
|
||||
| Iintop(Ilsl|Ilsr|Iasr) | Iintop_imm(_, _) | Ifloatofint | Iintoffloat |
|
||||
Ispecific(Ipush) ->
|
||||
(* The argument(s) can be either in register or on stack *)
|
||||
(arg, res)
|
||||
| _ -> (* Other operations: all args and results in registers *)
|
||||
raise Use_default
|
||||
|
||||
(* Scheduling is turned off because our model does not fit the 486
|
||||
nor Pentium very well. In particular, it messes up with the
|
||||
float reg stack. *)
|
||||
|
||||
let need_scheduling = false
|
||||
|
||||
let oper_latency _ = 0
|
||||
|
||||
(* Layout of the stack frame *)
|
||||
|
||||
let num_stack_slots = [| 0; 0 |]
|
||||
let contains_calls = ref false
|
||||
|
||||
(* Calling the assembler *)
|
||||
|
||||
let assemble_file infile outfile =
|
||||
Ccomp.command ("ml /nologo /coff /Cp /c /Fo" ^ outfile ^ " " ^ infile ^ ">NUL")
|
||||
(* /Cp preserve case of all used identifiers
|
||||
/c assemble only
|
||||
/Fo output file name *)
|
||||
|
||||
|
|
@ -1,347 +0,0 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Description of the Motorola 68020 processor *)
|
||||
|
||||
open Misc
|
||||
open Arch
|
||||
open Format
|
||||
open Cmm
|
||||
open Reg
|
||||
open Mach
|
||||
|
||||
(* Registers available for register allocation *)
|
||||
|
||||
(* Register map:
|
||||
A0 - A6 0-6 address registers (A2-A6 callee-save)
|
||||
A7 stack pointer
|
||||
D0 - D4 7-11 data registers (D2 - D7 callee-save)
|
||||
D5 temporary
|
||||
D6 allocation pointer
|
||||
D7 trap pointer
|
||||
FP0 - FP7 12-19 floating-point registers (FP2 - FP7 callee-save)
|
||||
*)
|
||||
|
||||
let register_names =
|
||||
[| "a0"; "a1"; "a2"; "a3"; "a4"; "a5"; "a6";
|
||||
"d0"; "d1"; "d2"; "d3"; "d4";
|
||||
"fp0"; "fp1"; "fp2"; "fp3"; "fp4"; "fp5"; "fp6"; "fp7" |]
|
||||
|
||||
let num_register_classes = 3
|
||||
|
||||
let register_class r =
|
||||
match r.typ with
|
||||
Addr -> 0
|
||||
| Int -> 1
|
||||
| Float -> 2
|
||||
|
||||
let num_available_registers = [| 7; 5; 8 |]
|
||||
|
||||
let first_available_register = [| 0; 7; 12 |]
|
||||
|
||||
let register_name r = register_names.(r)
|
||||
|
||||
(* There is no scheduling, so just pack registers. *)
|
||||
|
||||
let rotate_registers = false
|
||||
|
||||
(* Representation of hard registers by pseudo-registers *)
|
||||
|
||||
let all_phys_regs =
|
||||
let v = Array.create 20 Reg.dummy in
|
||||
for i = 0 to 6 do v.(i) <- Reg.at_location Addr (Reg i) done;
|
||||
for i = 7 to 11 do v.(i) <- Reg.at_location Int (Reg i) done;
|
||||
for i = 12 to 19 do v.(i) <- Reg.at_location Float (Reg i) done;
|
||||
v
|
||||
|
||||
let phys_reg n = all_phys_regs.(n)
|
||||
|
||||
let stack_slot slot ty = Reg.at_location ty (Stack slot)
|
||||
|
||||
let reg_A0 = phys_reg 0
|
||||
let reg_FP0 = phys_reg 12
|
||||
|
||||
(* Exceptions raised to signal cases not handled here *)
|
||||
|
||||
exception Use_default
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
(* Auxiliary for recognizing addressing modes *)
|
||||
|
||||
type addressing_expr =
|
||||
Asymbol of string
|
||||
| Alinear of expression
|
||||
| Aadd of expression * expression
|
||||
| Ascale of expression * int
|
||||
| Ascaledadd of expression * expression * int
|
||||
|
||||
let rec select_addr exp =
|
||||
match exp with
|
||||
Cconst_symbol s ->
|
||||
(Asymbol s, 0)
|
||||
| Cop((Caddi | Cadda), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Csubi | Csuba), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n - m)
|
||||
| Cop((Caddi | Cadda), [Cconst_int m; arg]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, mult), n * mult)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) ->
|
||||
begin match select_addr arg with
|
||||
(Alinear e, n) -> (Ascale(e, mult), n * mult)
|
||||
| _ -> (Alinear exp, 0)
|
||||
end
|
||||
| Cop((Caddi | Cadda), [arg1; arg2]) ->
|
||||
begin match (select_addr arg1, select_addr arg2) with
|
||||
((Alinear e1, n1), (Alinear e2, n2)) ->
|
||||
(Aadd(e1, e2), n1 + n2)
|
||||
| ((Alinear e1, n1), (Ascale(e2, scale), n2)) ->
|
||||
(Ascaledadd(e1, e2, scale), n1 + n2)
|
||||
| ((Ascale(e1, scale), n1), (Alinear e2, n2)) ->
|
||||
(Ascaledadd(e2, e1, scale), n1 + n2)
|
||||
| (_, (Ascale(e2, scale), n2)) ->
|
||||
(Ascaledadd(arg1, e2, scale), n2)
|
||||
| ((Ascale(e1, scale), n1), _) ->
|
||||
(Ascaledadd(arg2, e1, scale), n1)
|
||||
| _ ->
|
||||
(Aadd(arg1, arg2), 0)
|
||||
end
|
||||
| arg ->
|
||||
(Alinear arg, 0)
|
||||
|
||||
let select_addressing exp =
|
||||
match select_addr exp with
|
||||
(Asymbol s, d) ->
|
||||
(Ibased(s, d), Ctuple [])
|
||||
| (Alinear e, d) ->
|
||||
(Iindexed d, e)
|
||||
| (Aadd(e1, e2), d) ->
|
||||
(Iindexed2 d, Ctuple[e1; e2])
|
||||
| (Ascale(e, scale), d) ->
|
||||
(Iscaled(scale, d), e)
|
||||
| (Ascaledadd(e1, e2, scale), d) ->
|
||||
(Iindexed2scaled(scale, d), Ctuple[e1; e2])
|
||||
|
||||
(* Selection of immediate shifts *)
|
||||
|
||||
let select_shift op args =
|
||||
match args with
|
||||
[arg1; Cconst_int n] when n >= 1 && n <= 8 -> (Iintop_imm(op, n), [arg1])
|
||||
| _ -> (Iintop op, args)
|
||||
|
||||
(* Main instruction selection functions *)
|
||||
|
||||
let select_oper op args =
|
||||
match op with
|
||||
(* Recognize the LEA instruction *)
|
||||
Cadda | Csuba ->
|
||||
begin match select_addressing (Cop(op, args)) with
|
||||
(Iindexed d, _) -> raise Use_default
|
||||
| (addr, arg) -> (Ispecific(Ilea addr), [arg])
|
||||
end
|
||||
(* Recognize immediate shifts only if 1 <= count <= 8 *)
|
||||
| Clsl -> select_shift Ilsl args
|
||||
| Clsr -> select_shift Ilsr args
|
||||
| Casr -> select_shift Iasr args
|
||||
(* Recognize store instructions *)
|
||||
| Cstore ->
|
||||
begin match args with
|
||||
[loc; Cconst_int n] ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Istore_int(n, addr)), [arg])
|
||||
| [loc; Cconst_pointer n] ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Istore_int(n, addr)), [arg])
|
||||
| [loc; Cconst_symbol s] ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Istore_symbol(s, addr)), [arg])
|
||||
| _ ->
|
||||
raise Use_default
|
||||
end
|
||||
| _ -> raise Use_default
|
||||
|
||||
let select_store addr exp =
|
||||
match exp with
|
||||
Cconst_int n -> (Ispecific(Istore_int(n, addr)), Ctuple [])
|
||||
| Cconst_pointer n -> (Ispecific(Istore_int(n, addr)), Ctuple [])
|
||||
| Cconst_symbol s -> (Ispecific(Istore_symbol(s, addr)), Ctuple [])
|
||||
| _ -> raise Use_default
|
||||
|
||||
let select_push exp =
|
||||
match exp with
|
||||
Cconst_int n -> (Ispecific(Ipush_int n), Ctuple [])
|
||||
| Cconst_pointer n -> (Ispecific(Ipush_int n), Ctuple [])
|
||||
| Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
|
||||
| Cop(Cload ty, [loc]) when ty = typ_float ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Ipush_load_float addr), arg)
|
||||
| Cop(Cload ty, [loc]) when ty = typ_addr or ty = typ_int ->
|
||||
let (addr, arg) = select_addressing loc in
|
||||
(Ispecific(Ipush_load addr), arg)
|
||||
| _ -> (Ispecific(Ipush), exp)
|
||||
|
||||
let pseudoregs_for_operation op arg res =
|
||||
match op with
|
||||
(* Two-address binary operations *)
|
||||
Iintop(Iadd | Isub | Imul | Idiv | Imod | Ilsl | Ilsr | Iasr) |
|
||||
Iaddf | Isubf | Imulf | Idivf ->
|
||||
([|res.(0); arg.(1)|], res, false)
|
||||
(* Two-address binary operations, forcing the second argument to be
|
||||
in a data register *)
|
||||
| Iintop(Iand | Ior | Ixor) ->
|
||||
let newarg1 = Reg.create Int in
|
||||
([|res.(0); newarg1|], res, false)
|
||||
(* Two-address unary operations *)
|
||||
| Iintop_imm((Iadd | Isub | Imul | Idiv | Imod | Iand | Ior | Ixor |
|
||||
Ilsl | Ilsr | Iasr), _) ->
|
||||
(res, res, false)
|
||||
(* Other instructions are regular *)
|
||||
| _ -> raise Use_default
|
||||
|
||||
let is_immediate (n: int) = true
|
||||
|
||||
let word_addressed = false
|
||||
|
||||
(* Calling conventions *)
|
||||
|
||||
let calling_conventions first_addr last_addr first_float last_float
|
||||
make_stack arg =
|
||||
let loc = Array.create (Array.length arg) Reg.dummy in
|
||||
let addr = ref first_addr in
|
||||
let float = ref first_float in
|
||||
let ofs = ref 0 in
|
||||
for i = 0 to Array.length arg - 1 do
|
||||
match arg.(i).typ with
|
||||
(Addr | Int) as ty ->
|
||||
if !addr <= last_addr then begin
|
||||
loc.(i) <- phys_reg !addr;
|
||||
incr addr
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) ty;
|
||||
ofs := !ofs + size_addr
|
||||
end
|
||||
| Float ->
|
||||
if !float <= last_float then begin
|
||||
loc.(i) <- phys_reg !float;
|
||||
incr float
|
||||
end else begin
|
||||
loc.(i) <- stack_slot (make_stack !ofs) Float;
|
||||
ofs := !ofs + size_float
|
||||
end
|
||||
done;
|
||||
(loc, !ofs)
|
||||
|
||||
let incoming ofs = Incoming ofs
|
||||
let outgoing ofs = Outgoing ofs
|
||||
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
|
||||
|
||||
let loc_arguments arg =
|
||||
calling_conventions 0 5 12 18 outgoing arg
|
||||
let loc_parameters arg =
|
||||
let (loc, ofs) = calling_conventions 0 5 12 18 incoming arg in loc
|
||||
let loc_results res =
|
||||
let (loc, ofs) = calling_conventions 0 5 12 18 not_supported res in loc
|
||||
let extcall_use_push = true
|
||||
let loc_external_arguments arg =
|
||||
fatal_error "Proc.loc_external_arguments"
|
||||
let loc_external_results res =
|
||||
let (loc, ofs) = calling_conventions 7 7 12 12 not_supported res in loc
|
||||
|
||||
let loc_exn_bucket = reg_A0
|
||||
|
||||
(* Registers destroyed by operations *)
|
||||
|
||||
let destroyed_at_c_call =
|
||||
Array.of_list(List.map phys_reg [0; 1; 7; 8; 12; 13])
|
||||
|
||||
let destroyed_at_oper = function
|
||||
Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
|
||||
| Iop(Iextcall(_, false)) -> destroyed_at_c_call
|
||||
| Iop(Iintoffloat) -> [| reg_FP0 |]
|
||||
| _ -> [||]
|
||||
|
||||
let destroyed_at_raise = all_phys_regs
|
||||
|
||||
(* Maximal register pressure *)
|
||||
|
||||
let safe_register_pressure op = 5
|
||||
|
||||
let max_register_pressure = function
|
||||
Iextcall(_, _) -> [| 5; 3; 6 |]
|
||||
| Iintoffloat -> [| 7; 5; 7 |]
|
||||
| _ -> num_available_registers
|
||||
|
||||
(* Reloading of instruction arguments, storing of instruction results. *)
|
||||
|
||||
let stackp r =
|
||||
match r.loc with
|
||||
Stack _ -> true
|
||||
| _ -> false
|
||||
|
||||
let reload_test makereg round tst arg =
|
||||
match tst with
|
||||
Iinttest _ | Ifloattest _ ->
|
||||
(* The second argument can be on stack *)
|
||||
[| makereg arg.(0); arg.(1) |]
|
||||
| _ ->
|
||||
(* The argument can be on stack *)
|
||||
arg
|
||||
|
||||
let reload_operation makereg round op arg res =
|
||||
match op with
|
||||
Imove | Ireload | Ispill |
|
||||
Iintop_imm((Iadd | Isub | Iand | Ior | Ixor |
|
||||
Icomp _ | Ilsl | Ilsr | Iasr), _) |
|
||||
Ifloatofint | Iintoffloat | Ispecific(Ipush) ->
|
||||
(* The argument(s) can be either in register or on stack *)
|
||||
(arg, res)
|
||||
| Iintop(Iadd | Isub | Iand | Ior | Ixor | Icomp _) ->
|
||||
(* One of the two arguments can reside in the stack *)
|
||||
if stackp arg.(0) && stackp arg.(1)
|
||||
then ([|arg.(0); makereg arg.(1)|], res)
|
||||
else (arg, res)
|
||||
| Iintop(Ilsl | Ilsr | Iasr) ->
|
||||
(* The first argument and result can reside in the stack *)
|
||||
([|arg.(0); makereg arg.(1)|], res)
|
||||
| Iintop(Imul | Idiv | Imod) | Iaddf | Isubf | Imulf | Idivf ->
|
||||
(* The second argument can reside in the stack *)
|
||||
let r = makereg arg.(0) in ([|r; arg.(1)|], [|r|])
|
||||
| _ -> (* Other operations: all args and results in registers *)
|
||||
raise Use_default
|
||||
|
||||
(* Scheduling is turned off. *)
|
||||
|
||||
let need_scheduling = false
|
||||
|
||||
let oper_latency _ = 0
|
||||
|
||||
(* Layout of the stack frame *)
|
||||
|
||||
let num_stack_slots = [| 0; 0; 0 |]
|
||||
let contains_calls = ref false
|
||||
|
||||
(* Calling the assembler *)
|
||||
|
||||
let assemble_file infile outfile =
|
||||
Ccomp.command ("as -o " ^ outfile ^ " " ^ infile)
|
||||
|
||||
|
|
@ -13,10 +13,5 @@
|
|||
|
||||
(* Insert load/stores for pseudoregs that got assigned to stack locations. *)
|
||||
|
||||
val fundecl: int -> Mach.fundecl -> Mach.fundecl * bool
|
||||
val fundecl: Mach.fundecl -> Mach.fundecl * bool
|
||||
|
||||
(* Auxiliary functions for use by the processor description to do its own
|
||||
reloading *)
|
||||
|
||||
val makereg: Reg.t -> Reg.t
|
||||
val makeregs: Reg.t array -> Reg.t array
|
||||
|
|
|
|||
|
|
@ -11,15 +11,12 @@
|
|||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Insert load/stores for pseudoregs that got assigned to stack locations.
|
||||
Insert moves to comply with calling conventions, etc. *)
|
||||
(* Insert load/stores for pseudoregs that got assigned to stack locations. *)
|
||||
|
||||
open Misc
|
||||
open Reg
|
||||
open Mach
|
||||
|
||||
let redo_regalloc = ref false
|
||||
|
||||
let access_stack r =
|
||||
try
|
||||
for i = 0 to Array.length r - 1 do
|
||||
|
|
@ -29,32 +26,6 @@ let access_stack r =
|
|||
with Exit ->
|
||||
true
|
||||
|
||||
let makereg r =
|
||||
match r.loc with
|
||||
Unknown -> fatal_error "Reload.makereg"
|
||||
| Reg _ -> r
|
||||
| Stack _ ->
|
||||
if Proc.num_available_registers.(Proc.register_class r) = 0
|
||||
then r
|
||||
else begin
|
||||
redo_regalloc := true;
|
||||
let newr = Reg.clone r in
|
||||
(* Strongly discourage spilling this register *)
|
||||
newr.spill_cost <- 100000;
|
||||
newr
|
||||
end
|
||||
|
||||
let makeregs rv =
|
||||
let n = Array.length rv in
|
||||
let newv = Array.create n Reg.dummy in
|
||||
for i = 0 to n-1 do newv.(i) <- makereg rv.(i) done;
|
||||
newv
|
||||
|
||||
let makereg1 rv =
|
||||
let newv = Array.copy rv in
|
||||
newv.(0) <- makereg rv.(0);
|
||||
newv
|
||||
|
||||
let insert_move src dst next =
|
||||
if src.loc = dst.loc
|
||||
then next
|
||||
|
|
@ -67,10 +38,52 @@ let insert_moves src dst next =
|
|||
else insert_move src.(i) dst.(i) (insmoves (i+1))
|
||||
in insmoves 0
|
||||
|
||||
let reload_round = ref 0
|
||||
class reload_generic () as self =
|
||||
|
||||
val private mutable redo_regalloc = false
|
||||
|
||||
let rec reload i =
|
||||
method makereg r =
|
||||
match r.loc with
|
||||
Unknown -> fatal_error "Reload.makereg"
|
||||
| Reg _ -> r
|
||||
| Stack _ ->
|
||||
redo_regalloc <- true;
|
||||
let newr = Reg.clone r in
|
||||
(* Strongly discourage spilling this register *)
|
||||
newr.spill_cost <- 100000;
|
||||
newr
|
||||
|
||||
method makeregs rv =
|
||||
let n = Array.length rv in
|
||||
let newv = Array.create n Reg.dummy in
|
||||
for i = 0 to n-1 do newv.(i) <- self#makereg rv.(i) done;
|
||||
newv
|
||||
|
||||
method makereg1 rv =
|
||||
let newv = Array.copy rv in
|
||||
newv.(0) <- self#makereg rv.(0);
|
||||
newv
|
||||
|
||||
method reload_operation op arg res =
|
||||
(* By default, assume that arguments and results must reside
|
||||
in hardware registers. For moves, allow one arg or one
|
||||
res to be stack-allocated, but do something for
|
||||
stack-to-stack moves *)
|
||||
match op with
|
||||
Imove | Ireload | Ispill ->
|
||||
begin match arg.(0), res.(0) with
|
||||
{loc = Stack s1}, {loc = Stack s2} when s1 <> s2 ->
|
||||
([| self#makereg arg.(0) |], res)
|
||||
| _ ->
|
||||
(arg, res)
|
||||
end
|
||||
| _ ->
|
||||
(self#makeregs arg, self#makeregs res)
|
||||
|
||||
method reload_test tst args =
|
||||
self#makeregs args
|
||||
|
||||
method reload i =
|
||||
match i.desc with
|
||||
(* For function calls, returns, etc: the arguments and results are
|
||||
already at the correct position (e.g. on stack for some arguments).
|
||||
|
|
@ -78,72 +91,48 @@ let rec reload i =
|
|||
indirect calls. *)
|
||||
Iend | Ireturn | Iop(Itailcall_imm _) | Iraise -> i
|
||||
| Iop(Itailcall_ind) ->
|
||||
let newarg = makereg1 i.arg in
|
||||
let newarg = self#makereg1 i.arg in
|
||||
insert_moves i.arg newarg
|
||||
(instr_cons_live i.desc newarg i.res i.live i.next)
|
||||
| Iop(Icall_imm _ | Iextcall(_, _)) ->
|
||||
instr_cons_live i.desc i.arg i.res i.live (reload i.next)
|
||||
instr_cons_live i.desc i.arg i.res i.live (self#reload i.next)
|
||||
| Iop(Icall_ind) ->
|
||||
let newarg = makereg1 i.arg in
|
||||
let newarg = self#makereg1 i.arg in
|
||||
insert_moves i.arg newarg
|
||||
(instr_cons_live i.desc newarg i.res i.live (reload i.next))
|
||||
(instr_cons_live i.desc newarg i.res i.live (self#reload i.next))
|
||||
| Iop op ->
|
||||
(* Let the machine description tell us whether some arguments / results
|
||||
can reside on the stack *)
|
||||
let (newarg, newres) =
|
||||
try
|
||||
Proc.reload_operation makereg !reload_round op i.arg i.res
|
||||
with Proc.Use_default ->
|
||||
(* By default, assume that arguments and results must reside
|
||||
in hardware registers. For moves, allow one arg or one
|
||||
res to be stack-allocated, but do something for
|
||||
stack-to-stack moves *)
|
||||
match op with
|
||||
Imove | Ireload | Ispill ->
|
||||
begin match i.arg.(0), i.res.(0) with
|
||||
{loc = Stack s1}, {loc = Stack s2} when s1 <> s2 ->
|
||||
([| makereg i.arg.(0) |], i.res)
|
||||
| _ ->
|
||||
(i.arg, i.res)
|
||||
end
|
||||
| _ ->
|
||||
(makeregs i.arg, makeregs i.res) in
|
||||
let (newarg, newres) = self#reload_operation op i.arg i.res in
|
||||
insert_moves i.arg newarg
|
||||
(instr_cons_live i.desc newarg newres i.live
|
||||
(insert_moves newres i.res
|
||||
(reload i.next)))
|
||||
(self#reload i.next)))
|
||||
| Iifthenelse(tst, ifso, ifnot) ->
|
||||
(* Let the machine description tell us whether some arguments / results
|
||||
can reside on the stack *)
|
||||
let newarg =
|
||||
try
|
||||
Proc.reload_test makereg !reload_round tst i.arg
|
||||
with Proc.Use_default ->
|
||||
makeregs i.arg in
|
||||
let newarg = self#reload_test tst i.arg in
|
||||
insert_moves i.arg newarg
|
||||
(instr_cons (Iifthenelse(tst, reload ifso, reload ifnot)) newarg [||]
|
||||
(reload i.next))
|
||||
(instr_cons
|
||||
(Iifthenelse(tst, self#reload ifso, self#reload ifnot)) newarg [||]
|
||||
(self#reload i.next))
|
||||
| Iswitch(index, cases) ->
|
||||
let newarg = makeregs i.arg in
|
||||
let newarg = self#makeregs i.arg in
|
||||
insert_moves i.arg newarg
|
||||
(instr_cons (Iswitch(index, Array.map reload cases)) newarg [||]
|
||||
(reload i.next))
|
||||
(instr_cons (Iswitch(index, Array.map self#reload cases)) newarg [||]
|
||||
(self#reload i.next))
|
||||
| Iloop body ->
|
||||
instr_cons (Iloop(reload body)) [||] [||] (reload i.next)
|
||||
instr_cons (Iloop(self#reload body)) [||] [||] (self#reload i.next)
|
||||
| Icatch(body, handler) ->
|
||||
instr_cons (Icatch(reload body, reload handler)) [||] [||]
|
||||
(reload i.next)
|
||||
instr_cons (Icatch(self#reload body, self#reload handler)) [||] [||]
|
||||
(self#reload i.next)
|
||||
| Iexit ->
|
||||
instr_cons Iexit [||] [||] dummy_instr
|
||||
| Itrywith(body, handler) ->
|
||||
instr_cons (Itrywith(reload body, reload handler)) [||] [||]
|
||||
(reload i.next)
|
||||
instr_cons (Itrywith(self#reload body, self#reload handler)) [||] [||]
|
||||
(self#reload i.next)
|
||||
|
||||
let fundecl round f =
|
||||
redo_regalloc := false;
|
||||
reload_round := round;
|
||||
let new_body = reload f.fun_body in
|
||||
method fundecl f =
|
||||
redo_regalloc <- false;
|
||||
let new_body = self#reload f.fun_body in
|
||||
({fun_name = f.fun_name; fun_args = f.fun_args;
|
||||
fun_body = new_body; fun_fast = f.fun_fast},
|
||||
!redo_regalloc)
|
||||
redo_regalloc)
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1997 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
class reload_generic (unit) =
|
||||
method reload_operation :
|
||||
Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array * Reg.t array
|
||||
method reload_test : Mach.test -> Reg.t array -> Reg.t array
|
||||
(* Can be overriden to reflect instructions that can operate
|
||||
directly on stack locations *)
|
||||
method makereg : Reg.t -> Reg.t
|
||||
(* Can be overriden to avoid creating new registers of some class
|
||||
(i.e. if all "registers" of that class are actually on stack) *)
|
||||
method makereg1 : Reg.t array -> Reg.t array
|
||||
method makeregs : Reg.t array -> Reg.t array
|
||||
method reload : Mach.instruction -> Mach.instruction
|
||||
method fundecl : Mach.fundecl -> Mach.fundecl * bool
|
||||
end
|
||||
|
|
@ -18,41 +18,11 @@ open Reg
|
|||
open Mach
|
||||
open Linearize
|
||||
|
||||
(* Determine whether an instruction ends a basic block or not *)
|
||||
|
||||
let in_basic_block instr =
|
||||
match instr.desc with
|
||||
Lop op ->
|
||||
begin match op with
|
||||
Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ -> false
|
||||
| Iextcall(_, _) -> false
|
||||
| Istackoffset _ -> false
|
||||
| Istore(_, _) -> false
|
||||
| Ialloc _ -> false
|
||||
| op -> Proc.oper_latency op >= 0
|
||||
(* The processor description can return a latency of -1 to signal
|
||||
a specific instruction that terminates a basic block, e.g.
|
||||
Istore_symbol for the I386. *)
|
||||
end
|
||||
| Lreloadretaddr -> true
|
||||
| _ -> false
|
||||
|
||||
(* Estimate the delay needed to evaluate an instruction. *)
|
||||
|
||||
let reload_retaddr_latency =
|
||||
Proc.oper_latency (Iload(Cmm.Word, Arch.identity_addressing))
|
||||
|
||||
let instr_latency instr =
|
||||
match instr.desc with
|
||||
Lop op -> Proc.oper_latency op
|
||||
| Lreloadretaddr -> reload_retaddr_latency
|
||||
| _ -> fatal_error "Scheduling.instr_latency"
|
||||
|
||||
(* Representation of the code DAG. *)
|
||||
|
||||
type code_dag_node =
|
||||
{ instr: instruction; (* The instruction *)
|
||||
delay: int; (* How many cycles it needs *)
|
||||
delay: int; (* How many cycles before result is available *)
|
||||
mutable sons: (code_dag_node * int) list;
|
||||
(* Instructions that depend on it *)
|
||||
mutable date: int; (* Start date *)
|
||||
|
|
@ -75,57 +45,12 @@ let clear_code_dag () =
|
|||
Hashtbl.clear code_results;
|
||||
Hashtbl.clear code_uses
|
||||
|
||||
(* Add an instruction to the code DAG *)
|
||||
(* Add an edge to the code DAG *)
|
||||
|
||||
let add_edge ancestor son delay =
|
||||
ancestor.sons <- (son, delay) :: ancestor.sons;
|
||||
son.ancestors <- son.ancestors + 1
|
||||
|
||||
let add_instruction ready_queue instr =
|
||||
let delay = instr_latency instr in
|
||||
let node =
|
||||
{ instr = instr;
|
||||
delay = delay;
|
||||
sons = [];
|
||||
date = 0;
|
||||
length = -1;
|
||||
ancestors = 0;
|
||||
emitted_ancestors = 0 } in
|
||||
(* Add edges from all instructions that define one of the registers used *)
|
||||
for i = 0 to Array.length instr.arg - 1 do
|
||||
try
|
||||
let ancestor = Hashtbl.find code_results instr.arg.(i).loc in
|
||||
add_edge ancestor node ancestor.delay
|
||||
with Not_found ->
|
||||
()
|
||||
done;
|
||||
(* Also add edges from all instructions that use one of the results
|
||||
of this instruction, so that evaluation order is preserved. *)
|
||||
for i = 0 to Array.length instr.res - 1 do
|
||||
let ancestors = Hashtbl.find_all code_uses instr.res.(i).loc in
|
||||
List.iter (fun ancestor -> add_edge ancestor node 0) ancestors
|
||||
done;
|
||||
(* Also add edges from all instructions that have already defined one
|
||||
of the results of this instruction, so that evaluation order
|
||||
is preserved. *)
|
||||
for i = 0 to Array.length instr.res - 1 do
|
||||
try
|
||||
let ancestor = Hashtbl.find code_results instr.res.(i).loc in
|
||||
add_edge ancestor node 0
|
||||
with Not_found ->
|
||||
()
|
||||
done;
|
||||
(* Remember the registers used and produced by this instruction *)
|
||||
for i = 0 to Array.length instr.res - 1 do
|
||||
Hashtbl.add code_results instr.res.(i).loc node
|
||||
done;
|
||||
for i = 0 to Array.length instr.arg - 1 do
|
||||
Hashtbl.add code_uses instr.arg.(i).loc node
|
||||
done;
|
||||
(* If this is a root instruction (all arguments already computed),
|
||||
add it to the ready queue *)
|
||||
if node.ancestors = 0 then node :: ready_queue else ready_queue
|
||||
|
||||
(* Compute length of longest path to a result.
|
||||
For leafs of the DAG, see whether their result is used in the instruction
|
||||
immediately following the basic block (a "critical" output). *)
|
||||
|
|
@ -160,21 +85,6 @@ let rec longest_path critical_outputs node =
|
|||
end;
|
||||
node.length
|
||||
|
||||
(* Given a list of instructions with estimated start date, choose one
|
||||
that we can start (start date <= current date) and that has
|
||||
maximal distance to result. If we can't find any, return None. *)
|
||||
|
||||
let extract_ready_instr date queue =
|
||||
let rec extract best = function
|
||||
[] ->
|
||||
if best == dummy_node then None else Some best
|
||||
| instr :: rem ->
|
||||
let new_best =
|
||||
if instr.date <= date & instr.length > best.length
|
||||
then instr else best in
|
||||
extract new_best rem in
|
||||
extract dummy_node queue
|
||||
|
||||
(* Remove an instruction from the ready queue *)
|
||||
|
||||
let rec remove_instr node = function
|
||||
|
|
@ -182,66 +92,189 @@ let rec remove_instr node = function
|
|||
| instr :: rem ->
|
||||
if instr == node then rem else instr :: remove_instr node rem
|
||||
|
||||
(* We treat Lreloadretaddr as a word-sized load *)
|
||||
|
||||
let some_load = (Iload(Cmm.Word, Arch.identity_addressing))
|
||||
|
||||
(* The generic scheduler *)
|
||||
|
||||
class virtual scheduler_generic () as self =
|
||||
|
||||
(* Determine whether an operation ends a basic block or not.
|
||||
Can be overriden for some processors to signal specific instructions
|
||||
that terminate a basic block, e.g. Istore_symbol for the 386. *)
|
||||
|
||||
method oper_in_basic_block = function
|
||||
Icall_ind -> false
|
||||
| Icall_imm _ -> false
|
||||
| Itailcall_ind -> false
|
||||
| Itailcall_imm _ -> false
|
||||
| Iextcall(_, _) -> false
|
||||
| Istackoffset _ -> false
|
||||
| Istore(_, _) -> false
|
||||
| Ialloc _ -> false
|
||||
| _ -> true
|
||||
|
||||
(* Determine whether an instruction ends a basic block or not *)
|
||||
|
||||
method instr_in_basic_block instr =
|
||||
match instr.desc with
|
||||
Lop op -> self#oper_in_basic_block op
|
||||
| Lreloadretaddr -> true
|
||||
| _ -> false
|
||||
|
||||
(* Estimate the delay needed to evaluate an operation. *)
|
||||
|
||||
virtual oper_latency : Mach.operation -> int
|
||||
|
||||
(* Estimate the delay needed to evaluate an instruction *)
|
||||
|
||||
method instr_latency instr =
|
||||
match instr.desc with
|
||||
Lop op ->
|
||||
self#oper_latency op
|
||||
| Lreloadretaddr ->
|
||||
self#oper_latency some_load
|
||||
| _ ->
|
||||
assert false
|
||||
|
||||
(* Estimate the number of cycles consumed by emitting an operation. *)
|
||||
|
||||
virtual oper_issue_cycles : Mach.operation -> int
|
||||
|
||||
(* Estimate the number of cycles consumed by emitting an instruction. *)
|
||||
|
||||
method instr_issue_cycles instr =
|
||||
match instr.desc with
|
||||
Lop op ->
|
||||
self#oper_issue_cycles op
|
||||
| Lreloadretaddr ->
|
||||
self#oper_issue_cycles some_load
|
||||
| _ ->
|
||||
assert false
|
||||
|
||||
(* Add an instruction to the code dag *)
|
||||
|
||||
method add_instruction ready_queue instr =
|
||||
let delay = self#instr_latency instr in
|
||||
let node =
|
||||
{ instr = instr;
|
||||
delay = delay;
|
||||
sons = [];
|
||||
date = 0;
|
||||
length = -1;
|
||||
ancestors = 0;
|
||||
emitted_ancestors = 0 } in
|
||||
(* Add edges from all instructions that define one of the registers used
|
||||
(RAW dependencies) *)
|
||||
for i = 0 to Array.length instr.arg - 1 do
|
||||
try
|
||||
let ancestor = Hashtbl.find code_results instr.arg.(i).loc in
|
||||
add_edge ancestor node ancestor.delay
|
||||
with Not_found ->
|
||||
()
|
||||
done;
|
||||
(* Also add edges from all instructions that use one of the result regs
|
||||
of this instruction (WAR dependencies). *)
|
||||
for i = 0 to Array.length instr.res - 1 do
|
||||
let ancestors = Hashtbl.find_all code_uses instr.res.(i).loc in
|
||||
List.iter (fun ancestor -> add_edge ancestor node 0) ancestors
|
||||
done;
|
||||
(* Also add edges from all instructions that have already defined one
|
||||
of the results of this instruction (WAW dependencies). *)
|
||||
for i = 0 to Array.length instr.res - 1 do
|
||||
try
|
||||
let ancestor = Hashtbl.find code_results instr.res.(i).loc in
|
||||
add_edge ancestor node 0
|
||||
with Not_found ->
|
||||
()
|
||||
done;
|
||||
(* Remember the registers used and produced by this instruction *)
|
||||
for i = 0 to Array.length instr.res - 1 do
|
||||
Hashtbl.add code_results instr.res.(i).loc node
|
||||
done;
|
||||
for i = 0 to Array.length instr.arg - 1 do
|
||||
Hashtbl.add code_uses instr.arg.(i).loc node
|
||||
done;
|
||||
(* If this is a root instruction (all arguments already computed),
|
||||
add it to the ready queue *)
|
||||
if node.ancestors = 0 then node :: ready_queue else ready_queue
|
||||
|
||||
(* Given a list of instructions and a date, choose one or several
|
||||
that are ready to be computed (start date <= current date)
|
||||
and that we can emit in one cycle. Favor instructions with
|
||||
maximal distance to result. If we can't find any, return None.
|
||||
This does not take multiple issues into account, though. *)
|
||||
|
||||
method ready_instruction date queue =
|
||||
let rec extract best = function
|
||||
[] ->
|
||||
if best == dummy_node then None else Some best
|
||||
| instr :: rem ->
|
||||
let new_best =
|
||||
if instr.date <= date && instr.length > best.length
|
||||
then instr else best in
|
||||
extract new_best rem in
|
||||
extract dummy_node queue
|
||||
|
||||
(* Schedule a basic block, adding its instructions in front of the given
|
||||
instruction sequence *)
|
||||
|
||||
let rec reschedule ready_queue date cont =
|
||||
match ready_queue with
|
||||
[] -> cont
|
||||
| _ ->
|
||||
(* Find "most ready" instruction in queue *)
|
||||
match extract_ready_instr date ready_queue with
|
||||
None ->
|
||||
(* Try again, one cycle later *)
|
||||
reschedule ready_queue (date + 1) cont
|
||||
| Some node ->
|
||||
(* Update the start date and number of ancestors emitted of
|
||||
all descendents of this node. Enter those that become ready
|
||||
in the queue. *)
|
||||
let new_queue = ref (remove_instr node ready_queue) in
|
||||
List.iter
|
||||
(fun (son, delay) ->
|
||||
let completion_date = date + delay in
|
||||
if son.date < completion_date then son.date <- completion_date;
|
||||
son.emitted_ancestors <- son.emitted_ancestors + 1;
|
||||
if son.emitted_ancestors = son.ancestors then
|
||||
new_queue := son :: !new_queue)
|
||||
node.sons;
|
||||
instr_cons node.instr.desc node.instr.arg node.instr.res
|
||||
(reschedule !new_queue (date + 1) cont)
|
||||
|
||||
(* Schedule basic blocks in an instruction sequence *)
|
||||
|
||||
let rec schedule i =
|
||||
match i.desc with
|
||||
Lend -> i
|
||||
| _ ->
|
||||
if in_basic_block i then begin
|
||||
clear_code_dag();
|
||||
schedule_block [] i
|
||||
end else
|
||||
{ desc = i.desc; arg = i.arg; res = i.res; live = i.live;
|
||||
next = schedule i.next }
|
||||
|
||||
and schedule_block ready_queue i =
|
||||
if in_basic_block i then
|
||||
schedule_block (add_instruction ready_queue i) i.next
|
||||
else begin
|
||||
let critical_outputs =
|
||||
match i.desc with
|
||||
Lop(Icall_ind | Itailcall_ind) -> [| i.arg.(0) |]
|
||||
| Lop(Icall_imm _ | Itailcall_imm _ | Iextcall(_, _)) -> [||]
|
||||
| Lreturn -> [||]
|
||||
| _ -> i.arg in
|
||||
List.iter (longest_path critical_outputs) ready_queue;
|
||||
reschedule ready_queue 0 (schedule i)
|
||||
method reschedule ready_queue date cont =
|
||||
if ready_queue = [] then cont else begin
|
||||
match self#ready_instruction date ready_queue with
|
||||
None ->
|
||||
self#reschedule ready_queue (date + 1) cont
|
||||
| Some node ->
|
||||
(* Remove node from queue *)
|
||||
let new_queue = ref (remove_instr node ready_queue) in
|
||||
(* Update the start date and number of ancestors emitted of
|
||||
all descendents of this node. Enter those that become ready
|
||||
in the queue. *)
|
||||
List.iter
|
||||
(fun (son, delay) ->
|
||||
let completion_date = date + delay in
|
||||
if son.date < completion_date then son.date <- completion_date;
|
||||
son.emitted_ancestors <- son.emitted_ancestors + 1;
|
||||
if son.emitted_ancestors = son.ancestors then
|
||||
new_queue := son :: !new_queue)
|
||||
node.sons;
|
||||
let issue_cycles = self#instr_issue_cycles node.instr in
|
||||
instr_cons node.instr.desc node.instr.arg node.instr.res
|
||||
(self#reschedule !new_queue (date + issue_cycles) cont)
|
||||
end
|
||||
|
||||
(* Entry point *)
|
||||
(* Don't bother to schedule for initialization code and the like. *)
|
||||
|
||||
let fundecl f =
|
||||
if Proc.need_scheduling & f.fun_fast then begin
|
||||
method schedule_fundecl f =
|
||||
|
||||
let rec schedule i =
|
||||
match i.desc with
|
||||
Lend -> i
|
||||
| _ ->
|
||||
if self#instr_in_basic_block i then begin
|
||||
clear_code_dag();
|
||||
schedule_block [] i
|
||||
end else
|
||||
{ desc = i.desc; arg = i.arg; res = i.res; live = i.live;
|
||||
next = schedule i.next }
|
||||
|
||||
and schedule_block ready_queue i =
|
||||
if self#instr_in_basic_block i then
|
||||
schedule_block (self#add_instruction ready_queue i) i.next
|
||||
else begin
|
||||
let critical_outputs =
|
||||
match i.desc with
|
||||
Lop(Icall_ind | Itailcall_ind) -> [| i.arg.(0) |]
|
||||
| Lop(Icall_imm _ | Itailcall_imm _ | Iextcall(_, _)) -> [||]
|
||||
| Lreturn -> [||]
|
||||
| _ -> i.arg in
|
||||
List.iter (longest_path critical_outputs) ready_queue;
|
||||
self#reschedule ready_queue 0 (schedule i)
|
||||
end in
|
||||
|
||||
if f.fun_fast then begin
|
||||
let new_body = schedule f.fun_body in
|
||||
clear_code_dag();
|
||||
{ fun_name = f.fun_name;
|
||||
|
|
@ -249,3 +282,5 @@ let fundecl f =
|
|||
fun_fast = f.fun_fast }
|
||||
end else
|
||||
f
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1997 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Instruction scheduling *)
|
||||
|
||||
type code_dag_node =
|
||||
{ instr: Linearize.instruction;
|
||||
delay: int;
|
||||
mutable sons: (code_dag_node * int) list;
|
||||
mutable date: int;
|
||||
mutable length: int;
|
||||
mutable ancestors: int;
|
||||
mutable emitted_ancestors: int }
|
||||
|
||||
class virtual scheduler_generic (unit) =
|
||||
(* Can be overriden by processor description *)
|
||||
virtual oper_issue_cycles : Mach.operation -> int
|
||||
(* Number of cycles needed to issue the given operation *)
|
||||
virtual oper_latency : Mach.operation -> int
|
||||
(* Number of cycles needed to complete the given operation *)
|
||||
method oper_in_basic_block : Mach.operation -> bool
|
||||
(* Says whether the given operation terminates a basic block *)
|
||||
|
||||
(* Internal stuff, don't override *)
|
||||
method add_instruction :
|
||||
code_dag_node list -> Linearize.instruction -> code_dag_node list
|
||||
method instr_in_basic_block : Linearize.instruction -> bool
|
||||
method instr_issue_cycles : Linearize.instruction -> int
|
||||
method instr_latency : Linearize.instruction -> int
|
||||
method ready_instruction :
|
||||
int -> code_dag_node list -> code_dag_node option
|
||||
method reschedule :
|
||||
code_dag_node list ->
|
||||
int -> Linearize.instruction -> Linearize.instruction
|
||||
|
||||
(* Entry point *)
|
||||
method schedule_fundecl : Linearize.fundecl -> Linearize.fundecl
|
||||
end
|
||||
|
|
@ -19,6 +19,8 @@ open Cmm
|
|||
open Reg
|
||||
open Mach
|
||||
|
||||
type environment = (Ident.t, Reg.t array) Tbl.t
|
||||
|
||||
(* Infer the type of the result of an operation *)
|
||||
|
||||
let oper_result_type = function
|
||||
|
|
@ -93,133 +95,12 @@ let rec is_simple_expr = function
|
|||
end
|
||||
| _ -> false
|
||||
|
||||
(* Default instruction selection for operators *)
|
||||
(* Swap the two arguments of an integer comparison *)
|
||||
|
||||
let rec sel_operation op args =
|
||||
match (op, args) with
|
||||
(Capply ty, Cconst_symbol s :: rem) -> (Icall_imm s, rem)
|
||||
| (Capply ty, _) -> (Icall_ind, args)
|
||||
| (Cextcall(s, ty, alloc), _) -> (Iextcall(s, alloc), args)
|
||||
| (Cload ty, [arg]) ->
|
||||
let (addr, eloc) = Proc.select_addressing arg in
|
||||
(Iload(Word, addr), [eloc])
|
||||
| (Cloadchunk chunk, [arg]) ->
|
||||
let (addr, eloc) = Proc.select_addressing arg in
|
||||
(Iload(chunk, addr), [eloc])
|
||||
| (Cstore, [arg1; arg2]) ->
|
||||
let (addr, eloc) = Proc.select_addressing arg1 in
|
||||
begin try
|
||||
let (op, newarg2) = Proc.select_store addr arg2 in
|
||||
(op, [newarg2; eloc])
|
||||
with Proc.Use_default ->
|
||||
(Istore(Word, addr), [arg2; eloc])
|
||||
(* Inversion addr/datum in Istore *)
|
||||
end
|
||||
| (Cstorechunk chunk, [arg1; arg2]) ->
|
||||
let (addr, eloc) = Proc.select_addressing arg1 in
|
||||
(Istore(chunk, addr), [arg2; eloc])
|
||||
(* Inversion addr/datum in Istore *)
|
||||
| (Calloc, _) -> (Ialloc 0, args)
|
||||
| (Caddi, _) -> sel_arith_comm Iadd args
|
||||
| (Csubi, _) -> sel_arith Isub args
|
||||
| (Cmuli, [arg1; Cconst_int n]) ->
|
||||
let l = Misc.log2 n in
|
||||
if n = 1 lsl l
|
||||
then (Iintop_imm(Ilsl, l), [arg1])
|
||||
else sel_arith_comm Imul args
|
||||
| (Cmuli, [Cconst_int n; arg1]) ->
|
||||
let l = Misc.log2 n in
|
||||
if n = 1 lsl l
|
||||
then (Iintop_imm(Ilsl, l), [arg1])
|
||||
else sel_arith_comm Imul args
|
||||
| (Cmuli, _) -> sel_arith_comm Imul args
|
||||
| (Cdivi, _) -> sel_arith Idiv args
|
||||
| (Cmodi, _) -> sel_arith_comm Imod args
|
||||
| (Cand, _) -> sel_arith_comm Iand args
|
||||
| (Cor, _) -> sel_arith_comm Ior args
|
||||
| (Cxor, _) -> sel_arith_comm Ixor args
|
||||
| (Clsl, _) -> sel_shift Ilsl args
|
||||
| (Clsr, _) -> sel_shift Ilsr args
|
||||
| (Casr, _) -> sel_shift Iasr args
|
||||
| (Ccmpi comp, _) -> sel_arith_comp (Isigned comp) args
|
||||
| (Cadda, _) -> sel_arith_comm Iadd args
|
||||
| (Csuba, _) -> sel_arith Isub args
|
||||
| (Ccmpa comp, _) -> sel_arith_comp (Iunsigned comp) args
|
||||
| (Cnegf, _) -> (Inegf, args)
|
||||
| (Cabsf, _) -> (Iabsf, args)
|
||||
| (Caddf, _) -> (Iaddf, args)
|
||||
| (Csubf, _) -> (Isubf, args)
|
||||
| (Cmulf, _) -> (Imulf, args)
|
||||
| (Cdivf, _) -> (Idivf, args)
|
||||
| (Cfloatofint, _) -> (Ifloatofint, args)
|
||||
| (Cintoffloat, _) -> (Iintoffloat, args)
|
||||
| (Ccheckbound, _) -> sel_arith Icheckbound args
|
||||
| _ -> fatal_error "Selection.sel_oper"
|
||||
|
||||
and sel_arith_comm op = function
|
||||
[arg; Cconst_int n] when Proc.is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| [arg; Cconst_pointer n] when Proc.is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| [Cconst_int n; arg] when Proc.is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| [Cconst_pointer n; arg] when Proc.is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| args ->
|
||||
(Iintop op, args)
|
||||
|
||||
and sel_arith op = function
|
||||
[arg; Cconst_int n] when Proc.is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| [arg; Cconst_pointer n] when Proc.is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| args ->
|
||||
(Iintop op, args)
|
||||
|
||||
and sel_shift op = function
|
||||
[arg; Cconst_int n] when n >= 0 & n < Arch.size_int * 8 ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| args ->
|
||||
(Iintop op, args)
|
||||
|
||||
and sel_arith_comp cmp = function
|
||||
[arg; Cconst_int n] when Proc.is_immediate n ->
|
||||
(Iintop_imm(Icomp cmp, n), [arg])
|
||||
| [arg; Cconst_pointer n] when Proc.is_immediate n ->
|
||||
(Iintop_imm(Icomp cmp, n), [arg])
|
||||
| [Cconst_int n; arg] when Proc.is_immediate n ->
|
||||
(Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
|
||||
| [Cconst_pointer n; arg] when Proc.is_immediate n ->
|
||||
(Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
|
||||
| args ->
|
||||
(Iintop(Icomp cmp), args)
|
||||
|
||||
and swap_intcomp = function
|
||||
let swap_intcomp = function
|
||||
Isigned cmp -> Isigned(swap_comparison cmp)
|
||||
| Iunsigned cmp -> Iunsigned(swap_comparison cmp)
|
||||
|
||||
(* Instruction selection for conditionals *)
|
||||
|
||||
let sel_condition = function
|
||||
Cop(Ccmpi cmp, [arg1; Cconst_int n]) when Proc.is_immediate n ->
|
||||
(Iinttest_imm(Isigned cmp, n), arg1)
|
||||
| Cop(Ccmpi cmp, [Cconst_int n; arg2]) when Proc.is_immediate n ->
|
||||
(Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
|
||||
| Cop(Ccmpi cmp, args) ->
|
||||
(Iinttest(Isigned cmp), Ctuple args)
|
||||
| Cop(Ccmpa cmp, [arg1; Cconst_pointer n]) when Proc.is_immediate n ->
|
||||
(Iinttest_imm(Iunsigned cmp, n), arg1)
|
||||
| Cop(Ccmpa cmp, [Cconst_pointer n; arg2]) when Proc.is_immediate n ->
|
||||
(Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
|
||||
| Cop(Ccmpa cmp, args) ->
|
||||
(Iinttest(Iunsigned cmp), Ctuple args)
|
||||
| Cop(Ccmpf cmp, args) ->
|
||||
(Ifloattest(cmp, false), Ctuple args)
|
||||
| Cop(Cand, [arg; Cconst_int 1]) ->
|
||||
(Ioddtest, arg)
|
||||
| arg ->
|
||||
(Itruetest, arg)
|
||||
|
||||
(* Naming of registers *)
|
||||
|
||||
let all_regs_anonymous rv =
|
||||
|
|
@ -239,43 +120,6 @@ let name_regs id rv =
|
|||
rv.(i).name <- Ident.name id ^ "#" ^ string_of_int i
|
||||
done
|
||||
|
||||
(* Buffering of instruction sequences *)
|
||||
|
||||
type instruction_sequence = instruction ref
|
||||
|
||||
let new_sequence() = ref dummy_instr
|
||||
|
||||
let insert desc arg res seq =
|
||||
seq := instr_cons desc arg res !seq
|
||||
|
||||
let extract_sequence seq =
|
||||
let rec extract res i =
|
||||
if i == dummy_instr
|
||||
then res
|
||||
else extract (instr_cons i.desc i.arg i.res res) i.next in
|
||||
extract (end_instr()) !seq
|
||||
|
||||
(* Insert a sequence of moves from one pseudoreg set to another. *)
|
||||
|
||||
let insert_move src dst seq =
|
||||
if src.stamp <> dst.stamp then
|
||||
insert (Iop Imove) [|src|] [|dst|] seq
|
||||
|
||||
let insert_moves src dst seq =
|
||||
for i = 0 to Array.length src - 1 do
|
||||
insert_move src.(i) dst.(i) seq
|
||||
done
|
||||
|
||||
(* Insert moves and stack offsets for function arguments and results *)
|
||||
|
||||
let insert_move_args arg loc stacksize seq =
|
||||
if stacksize <> 0 then insert (Iop(Istackoffset stacksize)) [||] [||] seq;
|
||||
insert_moves arg loc seq
|
||||
|
||||
let insert_move_results loc res stacksize seq =
|
||||
if stacksize <> 0 then insert(Iop(Istackoffset(-stacksize))) [||] [||] seq;
|
||||
insert_moves loc res seq
|
||||
|
||||
(* "Join" two instruction sequences, making sure they return their results
|
||||
in the same registers. *)
|
||||
|
||||
|
|
@ -288,14 +132,14 @@ let join r1 seq1 r2 seq2 =
|
|||
for i = 0 to l1-1 do
|
||||
if String.length r1.(i).name = 0 then begin
|
||||
r.(i) <- r1.(i);
|
||||
insert_move r2.(i) r1.(i) seq2
|
||||
seq2#insert_move r2.(i) r1.(i)
|
||||
end else if String.length r2.(i).name = 0 then begin
|
||||
r.(i) <- r2.(i);
|
||||
insert_move r1.(i) r2.(i) seq1
|
||||
seq1#insert_move r1.(i) r2.(i)
|
||||
end else begin
|
||||
r.(i) <- Reg.create r1.(i).typ;
|
||||
insert_move r1.(i) r.(i) seq1;
|
||||
insert_move r2.(i) r.(i) seq2
|
||||
seq1#insert_move r1.(i) r.(i);
|
||||
seq2#insert_move r2.(i) r.(i)
|
||||
end
|
||||
done;
|
||||
r
|
||||
|
|
@ -317,51 +161,211 @@ let join_array rs =
|
|||
done;
|
||||
for i = 0 to Array.length rs - 1 do
|
||||
let (r, s) = rs.(i) in
|
||||
if Array.length r > 0 then insert_moves r res s
|
||||
if Array.length r > 0 then s#insert_moves r res
|
||||
done;
|
||||
res
|
||||
end
|
||||
|
||||
(* Add an Iop opcode.
|
||||
Offer the processor description an opportunity to insert moves
|
||||
before and after the operation, i.e. for two-address
|
||||
(* The default instruction selection class *)
|
||||
|
||||
class virtual selector_generic () as self =
|
||||
|
||||
(* Says whether an integer constant is a suitable immediate argument *)
|
||||
|
||||
virtual is_immediate : int -> bool
|
||||
|
||||
(* Selection of addressing modes *)
|
||||
|
||||
virtual select_addressing :
|
||||
Cmm.expression -> Arch.addressing_mode * Cmm.expression
|
||||
|
||||
(* Default instruction selection for stores *)
|
||||
|
||||
method select_store addr arg =
|
||||
(Istore(Word, addr), arg)
|
||||
|
||||
(* Default instruction selection for operators *)
|
||||
|
||||
method select_operation op args =
|
||||
match (op, args) with
|
||||
(Capply ty, Cconst_symbol s :: rem) -> (Icall_imm s, rem)
|
||||
| (Capply ty, _) -> (Icall_ind, args)
|
||||
| (Cextcall(s, ty, alloc), _) -> (Iextcall(s, alloc), args)
|
||||
| (Cload ty, [arg]) ->
|
||||
let (addr, eloc) = self#select_addressing arg in
|
||||
(Iload(Word, addr), [eloc])
|
||||
| (Cloadchunk chunk, [arg]) ->
|
||||
let (addr, eloc) = self#select_addressing arg in
|
||||
(Iload(chunk, addr), [eloc])
|
||||
| (Cstore, [arg1; arg2]) ->
|
||||
let (addr, eloc) = self#select_addressing arg1 in
|
||||
let (op, newarg2) = self#select_store addr arg2 in
|
||||
(op, [newarg2; eloc])
|
||||
(* Inversion addr/datum in Istore *)
|
||||
| (Cstorechunk chunk, [arg1; arg2]) ->
|
||||
let (addr, eloc) = self#select_addressing arg1 in
|
||||
(Istore(chunk, addr), [arg2; eloc])
|
||||
(* Inversion addr/datum in Istore *)
|
||||
| (Calloc, _) -> (Ialloc 0, args)
|
||||
| (Caddi, _) -> self#select_arith_comm Iadd args
|
||||
| (Csubi, _) -> self#select_arith Isub args
|
||||
| (Cmuli, [arg1; Cconst_int n]) ->
|
||||
let l = Misc.log2 n in
|
||||
if n = 1 lsl l
|
||||
then (Iintop_imm(Ilsl, l), [arg1])
|
||||
else self#select_arith_comm Imul args
|
||||
| (Cmuli, [Cconst_int n; arg1]) ->
|
||||
let l = Misc.log2 n in
|
||||
if n = 1 lsl l
|
||||
then (Iintop_imm(Ilsl, l), [arg1])
|
||||
else self#select_arith_comm Imul args
|
||||
| (Cmuli, _) -> self#select_arith_comm Imul args
|
||||
| (Cdivi, _) -> self#select_arith Idiv args
|
||||
| (Cmodi, _) -> self#select_arith_comm Imod args
|
||||
| (Cand, _) -> self#select_arith_comm Iand args
|
||||
| (Cor, _) -> self#select_arith_comm Ior args
|
||||
| (Cxor, _) -> self#select_arith_comm Ixor args
|
||||
| (Clsl, _) -> self#select_shift Ilsl args
|
||||
| (Clsr, _) -> self#select_shift Ilsr args
|
||||
| (Casr, _) -> self#select_shift Iasr args
|
||||
| (Ccmpi comp, _) -> self#select_arith_comp (Isigned comp) args
|
||||
| (Cadda, _) -> self#select_arith_comm Iadd args
|
||||
| (Csuba, _) -> self#select_arith Isub args
|
||||
| (Ccmpa comp, _) -> self#select_arith_comp (Iunsigned comp) args
|
||||
| (Cnegf, _) -> (Inegf, args)
|
||||
| (Cabsf, _) -> (Iabsf, args)
|
||||
| (Caddf, _) -> (Iaddf, args)
|
||||
| (Csubf, _) -> (Isubf, args)
|
||||
| (Cmulf, _) -> (Imulf, args)
|
||||
| (Cdivf, _) -> (Idivf, args)
|
||||
| (Cfloatofint, _) -> (Ifloatofint, args)
|
||||
| (Cintoffloat, _) -> (Iintoffloat, args)
|
||||
| (Ccheckbound, _) -> self#select_arith Icheckbound args
|
||||
| _ -> fatal_error "Selection.select_oper"
|
||||
|
||||
method select_arith_comm op = function
|
||||
[arg; Cconst_int n] when self#is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| [arg; Cconst_pointer n] when self#is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| [Cconst_int n; arg] when self#is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| [Cconst_pointer n; arg] when self#is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| args ->
|
||||
(Iintop op, args)
|
||||
|
||||
method select_arith op = function
|
||||
[arg; Cconst_int n] when self#is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| [arg; Cconst_pointer n] when self#is_immediate n ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| args ->
|
||||
(Iintop op, args)
|
||||
|
||||
method select_shift op = function
|
||||
[arg; Cconst_int n] when n >= 0 & n < Arch.size_int * 8 ->
|
||||
(Iintop_imm(op, n), [arg])
|
||||
| args ->
|
||||
(Iintop op, args)
|
||||
|
||||
method select_arith_comp cmp = function
|
||||
[arg; Cconst_int n] when self#is_immediate n ->
|
||||
(Iintop_imm(Icomp cmp, n), [arg])
|
||||
| [arg; Cconst_pointer n] when self#is_immediate n ->
|
||||
(Iintop_imm(Icomp cmp, n), [arg])
|
||||
| [Cconst_int n; arg] when self#is_immediate n ->
|
||||
(Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
|
||||
| [Cconst_pointer n; arg] when self#is_immediate n ->
|
||||
(Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
|
||||
| args ->
|
||||
(Iintop(Icomp cmp), args)
|
||||
|
||||
(* Instruction selection for conditionals *)
|
||||
|
||||
method select_condition = function
|
||||
Cop(Ccmpi cmp, [arg1; Cconst_int n]) when self#is_immediate n ->
|
||||
(Iinttest_imm(Isigned cmp, n), arg1)
|
||||
| Cop(Ccmpi cmp, [Cconst_int n; arg2]) when self#is_immediate n ->
|
||||
(Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
|
||||
| Cop(Ccmpi cmp, args) ->
|
||||
(Iinttest(Isigned cmp), Ctuple args)
|
||||
| Cop(Ccmpa cmp, [arg1; Cconst_pointer n]) when self#is_immediate n ->
|
||||
(Iinttest_imm(Iunsigned cmp, n), arg1)
|
||||
| Cop(Ccmpa cmp, [Cconst_pointer n; arg2]) when self#is_immediate n ->
|
||||
(Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
|
||||
| Cop(Ccmpa cmp, args) ->
|
||||
(Iinttest(Iunsigned cmp), Ctuple args)
|
||||
| Cop(Ccmpf cmp, args) ->
|
||||
(Ifloattest(cmp, false), Ctuple args)
|
||||
| Cop(Cand, [arg; Cconst_int 1]) ->
|
||||
(Ioddtest, arg)
|
||||
| arg ->
|
||||
(Itruetest, arg)
|
||||
|
||||
(* Buffering of instruction sequences *)
|
||||
|
||||
val private mutable instr_seq = dummy_instr
|
||||
|
||||
method insert desc arg res =
|
||||
instr_seq <- instr_cons desc arg res instr_seq
|
||||
|
||||
method extract =
|
||||
let rec extract res i =
|
||||
if i == dummy_instr
|
||||
then res
|
||||
else extract (instr_cons i.desc i.arg i.res res) i.next in
|
||||
extract (end_instr()) instr_seq
|
||||
|
||||
(* Insert a sequence of moves from one pseudoreg set to another. *)
|
||||
|
||||
method insert_move src dst =
|
||||
if src.stamp <> dst.stamp then
|
||||
self#insert (Iop Imove) [|src|] [|dst|]
|
||||
|
||||
method insert_moves src dst =
|
||||
for i = 0 to Array.length src - 1 do
|
||||
self#insert_move src.(i) dst.(i)
|
||||
done
|
||||
|
||||
(* Insert moves and stack offsets for function arguments and results *)
|
||||
|
||||
method insert_move_args arg loc stacksize =
|
||||
if stacksize <> 0 then self#insert (Iop(Istackoffset stacksize)) [||] [||];
|
||||
self#insert_moves arg loc
|
||||
|
||||
method insert_move_results loc res stacksize =
|
||||
if stacksize <> 0 then self#insert(Iop(Istackoffset(-stacksize))) [||] [||];
|
||||
self#insert_moves loc res
|
||||
|
||||
(* Add an Iop opcode. Can be overriden by processor description
|
||||
to insert moves before and after the operation, i.e. for two-address
|
||||
instructions, or instructions using dedicated registers. *)
|
||||
|
||||
let insert_op op rs rd seq =
|
||||
try
|
||||
let (rsrc, rdst, move_res) = Proc.pseudoregs_for_operation op rs rd in
|
||||
insert_moves rs rsrc seq;
|
||||
insert (Iop op) rsrc rdst seq;
|
||||
if move_res then begin
|
||||
insert_moves rdst rd seq;
|
||||
rd
|
||||
end else
|
||||
rdst
|
||||
with Proc.Use_default ->
|
||||
(* Assume no constraints on arg and res registers *)
|
||||
insert (Iop op) rs rd seq;
|
||||
rd
|
||||
method insert_op op rs rd =
|
||||
self#insert (Iop op) rs rd;
|
||||
rd
|
||||
|
||||
(* Add the instructions for the given expression
|
||||
at the end of the given sequence *)
|
||||
at the end of the self sequence *)
|
||||
|
||||
let rec emit_expr env exp seq =
|
||||
method emit_expr env exp =
|
||||
match exp with
|
||||
Cconst_int n ->
|
||||
let r = Reg.createv typ_int in
|
||||
insert_op (Iconst_int(Nativeint.from n)) [||] r seq
|
||||
self#insert_op (Iconst_int(Nativeint.from n)) [||] r
|
||||
| Cconst_natint n ->
|
||||
let r = Reg.createv typ_int in
|
||||
insert_op (Iconst_int n) [||] r seq
|
||||
self#insert_op (Iconst_int n) [||] r
|
||||
| Cconst_float n ->
|
||||
let r = Reg.createv typ_float in
|
||||
insert_op (Iconst_float n) [||] r seq
|
||||
self#insert_op (Iconst_float n) [||] r
|
||||
| Cconst_symbol n ->
|
||||
let r = Reg.createv typ_addr in
|
||||
insert_op (Iconst_symbol n) [||] r seq
|
||||
self#insert_op (Iconst_symbol n) [||] r
|
||||
| Cconst_pointer n ->
|
||||
let r = Reg.createv typ_addr in
|
||||
insert_op (Iconst_int(Nativeint.from n)) [||] r seq
|
||||
self#insert_op (Iconst_int(Nativeint.from n)) [||] r
|
||||
| Cvar v ->
|
||||
begin try
|
||||
Tbl.find v env
|
||||
|
|
@ -369,156 +373,136 @@ let rec emit_expr env exp seq =
|
|||
fatal_error("Selection.emit_expr: unbound var " ^ Ident.name v)
|
||||
end
|
||||
| Clet(v, e1, e2) ->
|
||||
emit_expr (emit_let env v e1 seq) e2 seq
|
||||
self#emit_expr (self#emit_let env v e1) e2
|
||||
| Cassign(v, e1) ->
|
||||
let rv =
|
||||
try
|
||||
Tbl.find v env
|
||||
with Not_found ->
|
||||
fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in
|
||||
let r1 = emit_expr env e1 seq in
|
||||
insert_moves r1 rv seq;
|
||||
let r1 = self#emit_expr env e1 in
|
||||
self#insert_moves r1 rv;
|
||||
[||]
|
||||
| Ctuple [] ->
|
||||
[||]
|
||||
| Ctuple exp_list ->
|
||||
let (simple_list, ext_env) = emit_parts_list env exp_list seq in
|
||||
emit_tuple ext_env simple_list seq
|
||||
let (simple_list, ext_env) = self#emit_parts_list env exp_list in
|
||||
self#emit_tuple ext_env simple_list
|
||||
| Cop(Cproj(ofs, len), [Cop(Cload ty, [arg])]) ->
|
||||
let byte_offset = size_machtype(Array.sub ty 0 ofs) in
|
||||
emit_expr env
|
||||
self#emit_expr env
|
||||
(Cop(Cload(Array.sub ty ofs len),
|
||||
[Cop(Cadda, [arg; Cconst_int byte_offset])])) seq
|
||||
[Cop(Cadda, [arg; Cconst_int byte_offset])]))
|
||||
| Cop(Cproj(ofs, len), [arg]) ->
|
||||
let r = emit_expr env arg seq in
|
||||
let r = self#emit_expr env arg in
|
||||
Array.sub r ofs len
|
||||
| Cop(Craise, [arg]) ->
|
||||
let r1 = emit_expr env arg seq in
|
||||
let r1 = self#emit_expr env arg in
|
||||
let rd = [|Proc.loc_exn_bucket|] in
|
||||
insert (Iop Imove) r1 rd seq;
|
||||
insert Iraise rd [||] seq;
|
||||
self#insert (Iop Imove) r1 rd;
|
||||
self#insert Iraise rd [||];
|
||||
[||]
|
||||
| Cop(Ccmpf comp, args) ->
|
||||
emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0)) seq
|
||||
self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0))
|
||||
| Cop(op, args) ->
|
||||
let (simple_args, env) = emit_parts_list env args seq in
|
||||
let (simple_args, env) = self#emit_parts_list env args in
|
||||
let ty = oper_result_type op in
|
||||
let (new_op, new_args) =
|
||||
try
|
||||
Proc.select_oper op simple_args
|
||||
with Proc.Use_default ->
|
||||
sel_operation op simple_args in
|
||||
let (new_op, new_args) = self#select_operation op simple_args in
|
||||
begin match new_op with
|
||||
Icall_ind ->
|
||||
Proc.contains_calls := true;
|
||||
let r1 = emit_tuple env new_args seq in
|
||||
let r1 = self#emit_tuple env new_args in
|
||||
let rarg = Array.sub r1 1 (Array.length r1 - 1) in
|
||||
let rd = Reg.createv ty in
|
||||
let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
|
||||
let loc_res = Proc.loc_results rd in
|
||||
insert_move_args rarg loc_arg stack_ofs seq;
|
||||
insert (Iop Icall_ind) (Array.append [|r1.(0)|] loc_arg) loc_res seq;
|
||||
insert_move_results loc_res rd stack_ofs seq;
|
||||
self#insert_move_args rarg loc_arg stack_ofs;
|
||||
self#insert (Iop Icall_ind)
|
||||
(Array.append [|r1.(0)|] loc_arg) loc_res;
|
||||
self#insert_move_results loc_res rd stack_ofs;
|
||||
rd
|
||||
| Icall_imm lbl ->
|
||||
Proc.contains_calls := true;
|
||||
let r1 = emit_tuple env new_args seq in
|
||||
let r1 = self#emit_tuple env new_args in
|
||||
let rd = Reg.createv ty in
|
||||
let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
|
||||
let loc_res = Proc.loc_results rd in
|
||||
insert_move_args r1 loc_arg stack_ofs seq;
|
||||
insert (Iop(Icall_imm lbl)) loc_arg loc_res seq;
|
||||
insert_move_results loc_res rd stack_ofs seq;
|
||||
self#insert_move_args r1 loc_arg stack_ofs;
|
||||
self#insert (Iop(Icall_imm lbl)) loc_arg loc_res;
|
||||
self#insert_move_results loc_res rd stack_ofs;
|
||||
rd
|
||||
| Iextcall(lbl, alloc) ->
|
||||
Proc.contains_calls := true;
|
||||
if Proc.extcall_use_push then begin
|
||||
let stack_ofs = emit_pushes env new_args seq in
|
||||
let rd = Reg.createv ty in
|
||||
let loc_res = Proc.loc_external_results rd in
|
||||
insert (Iop(Iextcall(lbl, alloc))) [||] loc_res seq;
|
||||
insert_move_results loc_res rd stack_ofs seq;
|
||||
rd
|
||||
end else begin
|
||||
let r1 = emit_tuple env new_args seq in
|
||||
let rd = Reg.createv ty in
|
||||
let (loc_arg, stack_ofs) = Proc.loc_external_arguments r1 in
|
||||
let loc_res = Proc.loc_external_results rd in
|
||||
insert_move_args r1 loc_arg stack_ofs seq;
|
||||
insert (Iop(Iextcall(lbl, alloc))) loc_arg loc_res seq;
|
||||
insert_move_results loc_res rd stack_ofs seq;
|
||||
rd
|
||||
end
|
||||
| Iload(Word, addr) ->
|
||||
let r1 = emit_tuple env new_args seq in
|
||||
let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in
|
||||
let rd = Reg.createv ty in
|
||||
insert_op (Iload(Word, addr)) r1 rd seq
|
||||
let loc_res = Proc.loc_external_results rd in
|
||||
self#insert (Iop(Iextcall(lbl, alloc))) loc_arg loc_res;
|
||||
self#insert_move_results loc_res rd stack_ofs;
|
||||
rd
|
||||
| Ialloc _ ->
|
||||
Proc.contains_calls := true;
|
||||
let rd = Reg.createv typ_addr in
|
||||
let size = size_expr env (Ctuple new_args) in
|
||||
insert (Iop(Ialloc size)) [||] rd seq;
|
||||
emit_stores env new_args seq rd
|
||||
self#insert (Iop(Ialloc size)) [||] rd;
|
||||
self#emit_stores env new_args rd
|
||||
(Arch.offset_addressing Arch.identity_addressing (-Arch.size_int));
|
||||
rd
|
||||
| op ->
|
||||
let r1 = emit_tuple env new_args seq in
|
||||
let r1 = self#emit_tuple env new_args in
|
||||
let rd = Reg.createv ty in
|
||||
insert_op op r1 rd seq
|
||||
self#insert_op op r1 rd
|
||||
end
|
||||
| Csequence(e1, e2) ->
|
||||
emit_expr env e1 seq;
|
||||
emit_expr env e2 seq
|
||||
self#emit_expr env e1;
|
||||
self#emit_expr env e2
|
||||
| Cifthenelse(econd, eif, eelse) ->
|
||||
let (cond, earg) = sel_condition econd in
|
||||
let rarg = emit_expr env earg seq in
|
||||
let (rif, sif) = emit_sequence env eif in
|
||||
let (relse, selse) = emit_sequence env eelse in
|
||||
let (cond, earg) = self#select_condition econd in
|
||||
let rarg = self#emit_expr env earg in
|
||||
let (rif, sif) = self#emit_sequence env eif in
|
||||
let (relse, selse) = self#emit_sequence env eelse in
|
||||
let r = join rif sif relse selse in
|
||||
insert (Iifthenelse(cond, extract_sequence sif, extract_sequence selse))
|
||||
rarg [||] seq;
|
||||
self#insert (Iifthenelse(cond, sif#extract, selse#extract)) rarg [||];
|
||||
r
|
||||
| Cswitch(esel, index, ecases) ->
|
||||
let rsel = emit_expr env esel seq in
|
||||
let rscases = Array.map (emit_sequence env) ecases in
|
||||
let rsel = self#emit_expr env esel in
|
||||
let rscases = Array.map (self#emit_sequence env) ecases in
|
||||
let r = join_array rscases in
|
||||
insert (Iswitch(index,
|
||||
Array.map (fun (r, s) -> extract_sequence s) rscases))
|
||||
rsel [||] seq;
|
||||
self#insert (Iswitch(index, Array.map (fun (r, s) -> s#extract) rscases))
|
||||
rsel [||];
|
||||
r
|
||||
| Cloop(ebody) ->
|
||||
let (rarg, sbody) = emit_sequence env ebody in
|
||||
insert (Iloop(extract_sequence sbody)) [||] [||] seq;
|
||||
let (rarg, sbody) = self#emit_sequence env ebody in
|
||||
self#insert (Iloop(sbody#extract)) [||] [||];
|
||||
[||]
|
||||
| Ccatch(e1, e2) ->
|
||||
let (r1, s1) = emit_sequence env e1 in
|
||||
let (r2, s2) = emit_sequence env e2 in
|
||||
let (r1, s1) = self#emit_sequence env e1 in
|
||||
let (r2, s2) = self#emit_sequence env e2 in
|
||||
let r = join r1 s1 r2 s2 in
|
||||
insert (Icatch(extract_sequence s1, extract_sequence s2)) [||] [||] seq;
|
||||
self#insert (Icatch(s1#extract, s2#extract)) [||] [||];
|
||||
r
|
||||
| Cexit ->
|
||||
insert Iexit [||] [||] seq;
|
||||
self#insert Iexit [||] [||];
|
||||
[||]
|
||||
| Ctrywith(e1, v, e2) ->
|
||||
Proc.contains_calls := true;
|
||||
let (r1, s1) = emit_sequence env e1 in
|
||||
let (r1, s1) = self#emit_sequence env e1 in
|
||||
let rv = Reg.createv typ_addr in
|
||||
let (r2, s2) = emit_sequence (Tbl.add v rv env) e2 in
|
||||
let (r2, s2) = self#emit_sequence (Tbl.add v rv env) e2 in
|
||||
let r = join r1 s1 r2 s2 in
|
||||
insert
|
||||
(Itrywith(extract_sequence s1,
|
||||
self#insert
|
||||
(Itrywith(s1#extract,
|
||||
instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv
|
||||
(extract_sequence s2)))
|
||||
[||] [||] seq;
|
||||
s2#extract))
|
||||
[||] [||];
|
||||
r
|
||||
|
||||
and emit_sequence env exp =
|
||||
let seq = new_sequence() in
|
||||
let r = emit_expr env exp seq in
|
||||
(r, seq)
|
||||
method emit_sequence env exp =
|
||||
let s = {< instr_seq = dummy_instr >} in
|
||||
let r = s#emit_expr env exp in
|
||||
(r, s)
|
||||
|
||||
and emit_let env v e1 seq =
|
||||
let r1 = emit_expr env e1 seq in
|
||||
method emit_let env v e1 =
|
||||
let r1 = self#emit_expr env e1 in
|
||||
if all_regs_anonymous r1 then begin
|
||||
name_regs v r1;
|
||||
Tbl.add v r1 env
|
||||
|
|
@ -526,15 +510,15 @@ and emit_let env v e1 seq =
|
|||
let rv = Array.create (Array.length r1) Reg.dummy in
|
||||
for i = 0 to Array.length r1 - 1 do rv.(i) <- Reg.create r1.(i).typ done;
|
||||
name_regs v rv;
|
||||
insert_moves r1 rv seq;
|
||||
self#insert_moves r1 rv;
|
||||
Tbl.add v rv env
|
||||
end
|
||||
|
||||
and emit_parts env exp seq =
|
||||
method emit_parts env exp =
|
||||
if is_simple_expr exp then
|
||||
(exp, env)
|
||||
else begin
|
||||
let r = emit_expr env exp seq in
|
||||
let r = self#emit_expr env exp in
|
||||
if Array.length r = 0 then
|
||||
(Ctuple [], env)
|
||||
else begin
|
||||
|
|
@ -546,160 +530,147 @@ and emit_parts env exp seq =
|
|||
for i = 0 to Array.length r - 1 do
|
||||
rv.(i) <- Reg.create r.(i).typ
|
||||
done;
|
||||
insert_moves r rv seq;
|
||||
self#insert_moves r rv;
|
||||
(Cvar id, Tbl.add id rv env)
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
and emit_parts_list env exp_list seq =
|
||||
method emit_parts_list env exp_list =
|
||||
match exp_list with
|
||||
[] -> ([], env)
|
||||
| exp :: rem ->
|
||||
(* This ensures right-to-left evaluation, consistent with the
|
||||
bytecode compiler *)
|
||||
let (new_rem, new_env) = emit_parts_list env rem seq in
|
||||
let (new_exp, fin_env) = emit_parts new_env exp seq in
|
||||
let (new_rem, new_env) = self#emit_parts_list env rem in
|
||||
let (new_exp, fin_env) = self#emit_parts new_env exp in
|
||||
(new_exp :: new_rem, fin_env)
|
||||
|
||||
and emit_tuple env exp_list seq =
|
||||
method emit_tuple env exp_list =
|
||||
let rec emit_list = function
|
||||
[] -> []
|
||||
| exp :: rem ->
|
||||
(* Again, force right-to-left evaluation *)
|
||||
let loc_rem = emit_list rem in
|
||||
let loc_exp = emit_expr env exp seq in
|
||||
let loc_exp = self#emit_expr env exp in
|
||||
loc_exp :: loc_rem in
|
||||
Array.concat(emit_list exp_list)
|
||||
|
||||
and emit_stores env data seq regs_addr addr =
|
||||
method emit_extcall_args env args =
|
||||
let r1 = self#emit_tuple env args in
|
||||
let (loc_arg, stack_ofs as arg_stack) = Proc.loc_external_arguments r1 in
|
||||
self#insert_move_args r1 loc_arg stack_ofs;
|
||||
arg_stack
|
||||
|
||||
method emit_stores env data regs_addr addr =
|
||||
let a = ref addr in
|
||||
List.iter
|
||||
(fun e ->
|
||||
try
|
||||
(* Offer the machine description an opportunity to optimize
|
||||
the store, e.g. if constant -> memory or memory -> memory
|
||||
moves are available *)
|
||||
let (op, arg) = Proc.select_store !a e in
|
||||
let r = emit_expr env arg seq in
|
||||
insert (Iop op) (Array.append r regs_addr) [||] seq;
|
||||
a := Arch.offset_addressing !a (size_expr env e)
|
||||
with Proc.Use_default ->
|
||||
let r = emit_expr env e seq in
|
||||
for i = 0 to Array.length r - 1 do
|
||||
insert (Iop(Istore(Word, !a)))
|
||||
(Array.append [|r.(i)|] regs_addr) [||] seq;
|
||||
a := Arch.offset_addressing !a (size_component r.(i).typ)
|
||||
done)
|
||||
let (op, arg) = self#select_store !a e in
|
||||
let r = self#emit_expr env arg in
|
||||
self#insert (Iop op) (Array.append r regs_addr) [||];
|
||||
a := Arch.offset_addressing !a (size_expr env e))
|
||||
data
|
||||
|
||||
and emit_pushes env args seq =
|
||||
match args with
|
||||
[] -> 0
|
||||
| e :: el ->
|
||||
let ofs = emit_pushes env el seq in
|
||||
let (op, arg) = Proc.select_push e in
|
||||
let r = emit_expr env arg seq in
|
||||
insert (Iop op) r [||] seq;
|
||||
ofs + size_expr env e
|
||||
|
||||
(* Same, but in tail position *)
|
||||
|
||||
let emit_return env exp seq =
|
||||
let r = emit_expr env exp seq in
|
||||
method emit_return env exp =
|
||||
let r = self#emit_expr env exp in
|
||||
let loc = Proc.loc_results r in
|
||||
insert_moves r loc seq;
|
||||
insert Ireturn loc [||] seq
|
||||
self#insert_moves r loc;
|
||||
self#insert Ireturn loc [||]
|
||||
|
||||
let rec emit_tail env exp seq =
|
||||
method emit_tail env exp =
|
||||
match exp with
|
||||
Clet(v, e1, e2) ->
|
||||
emit_tail (emit_let env v e1 seq) e2 seq
|
||||
self#emit_tail (self#emit_let env v e1) e2
|
||||
| Cop(Capply ty as op, args) ->
|
||||
let (simple_args, env) = emit_parts_list env args seq in
|
||||
let (new_op, new_args) = sel_operation op simple_args in
|
||||
let (simple_args, env) = self#emit_parts_list env args in
|
||||
let (new_op, new_args) = self#select_operation op simple_args in
|
||||
begin match new_op with
|
||||
Icall_ind ->
|
||||
let r1 = emit_tuple env new_args seq in
|
||||
let r1 = self#emit_tuple env new_args in
|
||||
let rarg = Array.sub r1 1 (Array.length r1 - 1) in
|
||||
let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
|
||||
if stack_ofs = 0 then begin
|
||||
insert_moves rarg loc_arg seq;
|
||||
insert (Iop Itailcall_ind)
|
||||
(Array.append [|r1.(0)|] loc_arg) [||] seq
|
||||
self#insert_moves rarg loc_arg;
|
||||
self#insert (Iop Itailcall_ind)
|
||||
(Array.append [|r1.(0)|] loc_arg) [||]
|
||||
end else begin
|
||||
Proc.contains_calls := true;
|
||||
let rd = Reg.createv ty in
|
||||
let loc_res = Proc.loc_results rd in
|
||||
insert_move_args rarg loc_arg stack_ofs seq;
|
||||
insert (Iop Icall_ind)
|
||||
(Array.append [|r1.(0)|] loc_arg) loc_res seq;
|
||||
insert(Iop(Istackoffset(-stack_ofs))) [||] [||] seq;
|
||||
insert Ireturn loc_res [||] seq
|
||||
self#insert_move_args rarg loc_arg stack_ofs;
|
||||
self#insert (Iop Icall_ind)
|
||||
(Array.append [|r1.(0)|] loc_arg) loc_res;
|
||||
self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||];
|
||||
self#insert Ireturn loc_res [||]
|
||||
end
|
||||
| Icall_imm lbl ->
|
||||
let r1 = emit_tuple env new_args seq in
|
||||
let r1 = self#emit_tuple env new_args in
|
||||
let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
|
||||
if stack_ofs = 0 then begin
|
||||
insert_moves r1 loc_arg seq;
|
||||
insert (Iop(Itailcall_imm lbl)) loc_arg [||] seq
|
||||
self#insert_moves r1 loc_arg;
|
||||
self#insert (Iop(Itailcall_imm lbl)) loc_arg [||]
|
||||
end else begin
|
||||
Proc.contains_calls := true;
|
||||
let rd = Reg.createv ty in
|
||||
let loc_res = Proc.loc_results rd in
|
||||
insert_move_args r1 loc_arg stack_ofs seq;
|
||||
insert (Iop(Icall_imm lbl)) loc_arg loc_res seq;
|
||||
insert(Iop(Istackoffset(-stack_ofs))) [||] [||] seq;
|
||||
insert Ireturn loc_res [||] seq
|
||||
self#insert_move_args r1 loc_arg stack_ofs;
|
||||
self#insert (Iop(Icall_imm lbl)) loc_arg loc_res;
|
||||
self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||];
|
||||
self#insert Ireturn loc_res [||]
|
||||
end
|
||||
| _ -> fatal_error "Selection.emit_tail"
|
||||
end
|
||||
| Cop(Craise, [e1]) ->
|
||||
let r1 = emit_expr env e1 seq in
|
||||
let r1 = self#emit_expr env e1 in
|
||||
let rd = [|Proc.loc_exn_bucket|] in
|
||||
insert (Iop Imove) r1 rd seq;
|
||||
insert Iraise rd [||] seq
|
||||
self#insert (Iop Imove) r1 rd;
|
||||
self#insert Iraise rd [||]
|
||||
| Csequence(e1, e2) ->
|
||||
emit_expr env e1 seq;
|
||||
emit_tail env e2 seq
|
||||
self#emit_expr env e1;
|
||||
self#emit_tail env e2
|
||||
| Cifthenelse(econd, eif, eelse) ->
|
||||
let (cond, earg) = sel_condition econd in
|
||||
let rarg = emit_expr env earg seq in
|
||||
insert (Iifthenelse(cond, emit_tail_sequence env eif,
|
||||
emit_tail_sequence env eelse))
|
||||
rarg [||] seq
|
||||
let (cond, earg) = self#select_condition econd in
|
||||
let rarg = self#emit_expr env earg in
|
||||
self#insert (Iifthenelse(cond, self#emit_tail_sequence env eif,
|
||||
self#emit_tail_sequence env eelse))
|
||||
rarg [||]
|
||||
| Cswitch(esel, index, ecases) ->
|
||||
let rsel = emit_expr env esel seq in
|
||||
insert (Iswitch(index, Array.map (emit_tail_sequence env) ecases))
|
||||
rsel [||] seq
|
||||
let rsel = self#emit_expr env esel in
|
||||
self#insert
|
||||
(Iswitch(index, Array.map (self#emit_tail_sequence env) ecases))
|
||||
rsel [||]
|
||||
| Ccatch(e1, e2) ->
|
||||
insert (Icatch(emit_tail_sequence env e1, emit_tail_sequence env e2))
|
||||
[||] [||] seq
|
||||
self#insert (Icatch(self#emit_tail_sequence env e1,
|
||||
self#emit_tail_sequence env e2))
|
||||
[||] [||]
|
||||
| Cexit ->
|
||||
insert Iexit [||] [||] seq
|
||||
self#insert Iexit [||] [||]
|
||||
| Ctrywith(e1, v, e2) ->
|
||||
Proc.contains_calls := true;
|
||||
let (r1, s1) = emit_sequence env e1 in
|
||||
let (r1, s1) = self#emit_sequence env e1 in
|
||||
let rv = Reg.createv typ_addr in
|
||||
let s2 = emit_tail_sequence (Tbl.add v rv env) e2 in
|
||||
let s2 = self#emit_tail_sequence (Tbl.add v rv env) e2 in
|
||||
let loc = Proc.loc_results r1 in
|
||||
insert
|
||||
(Itrywith(extract_sequence s1,
|
||||
self#insert
|
||||
(Itrywith(s1#extract,
|
||||
instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv s2))
|
||||
[||] [||] seq;
|
||||
insert_moves r1 loc seq;
|
||||
insert Ireturn loc [||] seq
|
||||
[||] [||];
|
||||
self#insert_moves r1 loc;
|
||||
self#insert Ireturn loc [||]
|
||||
| _ ->
|
||||
emit_return env exp seq
|
||||
self#emit_return env exp
|
||||
|
||||
and emit_tail_sequence env exp =
|
||||
let seq = new_sequence() in
|
||||
emit_tail env exp seq;
|
||||
extract_sequence seq
|
||||
method emit_tail_sequence env exp =
|
||||
let s = {< instr_seq = dummy_instr >} in
|
||||
s#emit_tail env exp;
|
||||
s#extract
|
||||
|
||||
(* Sequentialization of a function definition *)
|
||||
|
||||
let fundecl f =
|
||||
method emit_fundecl f =
|
||||
Proc.contains_calls := false;
|
||||
let rargs =
|
||||
List.map
|
||||
|
|
@ -711,10 +682,11 @@ let fundecl f =
|
|||
List.fold_right2
|
||||
(fun (id, ty) r env -> Tbl.add id r env)
|
||||
f.Cmm.fun_args rargs Tbl.empty in
|
||||
let seq = new_sequence() in
|
||||
insert_moves loc_arg rarg seq;
|
||||
emit_tail env f.Cmm.fun_body seq;
|
||||
self#insert_moves loc_arg rarg;
|
||||
self#emit_tail env f.Cmm.fun_body;
|
||||
{ fun_name = f.Cmm.fun_name;
|
||||
fun_args = loc_arg;
|
||||
fun_body = extract_sequence seq;
|
||||
fun_body = self#extract;
|
||||
fun_fast = f.Cmm.fun_fast }
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,90 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Selection of pseudo-instructions, assignment of pseudo-registers,
|
||||
sequentialization. *)
|
||||
|
||||
type environment = (Ident.t, Reg.t array) Tbl.t
|
||||
|
||||
val size_expr : environment -> Cmm.expression -> int
|
||||
|
||||
class virtual selector_generic (unit) : 'a =
|
||||
(* The following methods must or can be overriden by the processor
|
||||
description *)
|
||||
virtual is_immediate : int -> bool
|
||||
(* Must be defined to indicate whether a constant is a suitable
|
||||
immediate operand to arithmetic instructions *)
|
||||
virtual select_addressing :
|
||||
Cmm.expression -> Arch.addressing_mode * Cmm.expression
|
||||
(* Must be defined to select addressing modes *)
|
||||
method select_operation :
|
||||
Cmm.operation ->
|
||||
Cmm.expression list -> Mach.operation * Cmm.expression list
|
||||
(* Can be overriden to deal with special arithmetic instructions *)
|
||||
method select_condition : Cmm.expression -> Mach.test * Cmm.expression
|
||||
(* Can be overriden to deal with special test instructions *)
|
||||
method select_store :
|
||||
Arch.addressing_mode -> Cmm.expression -> Mach.operation * Cmm.expression
|
||||
(* Can be overriden to deal with special store constant instructions *)
|
||||
method insert_op :
|
||||
Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array
|
||||
(* Can be overriden to deal with 2-address instructions
|
||||
or instructions with hardwired input/output registers *)
|
||||
method emit_extcall_args :
|
||||
environment -> Cmm.expression list -> Reg.t array * int
|
||||
(* Can be overriden to deal with stack-based calling conventions *)
|
||||
|
||||
(* The following methods should not be overriden *)
|
||||
method emit_expr :
|
||||
environment -> Cmm.expression -> Reg.t array
|
||||
method emit_fundecl : Cmm.fundecl -> Mach.fundecl
|
||||
method emit_let :
|
||||
environment ->
|
||||
Ident.t -> Cmm.expression -> environment
|
||||
method emit_parts :
|
||||
environment ->
|
||||
Cmm.expression -> Cmm.expression * environment
|
||||
method emit_parts_list :
|
||||
environment ->
|
||||
Cmm.expression list -> Cmm.expression list * environment
|
||||
method emit_return : environment -> Cmm.expression -> unit
|
||||
method emit_sequence :
|
||||
environment -> Cmm.expression -> Reg.t array * 'a
|
||||
method emit_stores :
|
||||
environment ->
|
||||
Cmm.expression list -> Reg.t array -> Arch.addressing_mode -> unit
|
||||
method emit_tail : environment -> Cmm.expression -> unit
|
||||
method emit_tail_sequence :
|
||||
environment -> Cmm.expression -> Mach.instruction
|
||||
method emit_tuple :
|
||||
environment -> Cmm.expression list -> Reg.t array
|
||||
method extract : Mach.instruction
|
||||
method insert : Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit
|
||||
method insert_move : Reg.t -> Reg.t -> unit
|
||||
method insert_move_args : Reg.t array -> Reg.t array -> int -> unit
|
||||
method insert_move_results : Reg.t array -> Reg.t array -> int -> unit
|
||||
method insert_moves : Reg.t array -> Reg.t array -> unit
|
||||
method select_arith :
|
||||
Mach.integer_operation ->
|
||||
Cmm.expression list -> Mach.operation * Cmm.expression list
|
||||
method select_arith_comm :
|
||||
Mach.integer_operation ->
|
||||
Cmm.expression list -> Mach.operation * Cmm.expression list
|
||||
method select_arith_comp :
|
||||
Mach.integer_comparison ->
|
||||
Cmm.expression list -> Mach.operation * Cmm.expression list
|
||||
method select_shift :
|
||||
Mach.integer_operation ->
|
||||
Cmm.expression list -> Mach.operation * Cmm.expression list
|
||||
end
|
||||
|
||||
|
|
@ -19,76 +19,8 @@ open Reg
|
|||
open Arch
|
||||
open Mach
|
||||
|
||||
(* Exceptions raised to signal cases not handled here *)
|
||||
|
||||
exception Use_default
|
||||
|
||||
(* Recognition of addressing modes *)
|
||||
|
||||
type addressing_expr =
|
||||
Asymbol of string
|
||||
| Alinear of expression
|
||||
| Aadd of expression * expression
|
||||
|
||||
let rec select_addr = function
|
||||
Cconst_symbol s ->
|
||||
(Asymbol s, 0)
|
||||
| Cop((Caddi | Cadda), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Caddi | Cadda), [Cconst_int m; arg]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Caddi | Cadda), [arg1; arg2]) ->
|
||||
begin match (select_addr arg1, select_addr arg2) with
|
||||
((Alinear e1, n1), (Alinear e2, n2)) ->
|
||||
(Aadd(e1, e2), n1 + n2)
|
||||
| _ ->
|
||||
(Aadd(arg1, arg2), 0)
|
||||
end
|
||||
| exp ->
|
||||
(Alinear exp, 0)
|
||||
|
||||
let select_addressing exp =
|
||||
match select_addr exp with
|
||||
(Asymbol s, d) ->
|
||||
(Ibased(s, d), Ctuple [])
|
||||
| (Alinear e, d) ->
|
||||
(Iindexed d, e)
|
||||
| (Aadd(e1, e2), d) ->
|
||||
(Iindexed2 d, Ctuple[e1; e2])
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
let is_immediate n = (n <= 4095) & (n >= -4096)
|
||||
|
||||
let select_oper op args =
|
||||
match (op, args) with
|
||||
(* Multiplication, division and modulus are turned into
|
||||
calls to C library routines, except if the dividend is a power of 2. *)
|
||||
(Cmuli, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Ilsl, Misc.log2 n), [arg])
|
||||
| (Cmuli, [Cconst_int n; arg]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Ilsl, Misc.log2 n), [arg])
|
||||
| (Cmuli, _) ->
|
||||
(Iextcall(".umul", false), args)
|
||||
| (Cdivi, [arg; Cconst_int n])
|
||||
when is_immediate n & n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Idiv, n), [arg])
|
||||
| (Cdivi, _) ->
|
||||
(Iextcall(".div", false), args)
|
||||
| (Cmodi, [arg; Cconst_int n])
|
||||
when is_immediate n & n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Imod, n), [arg])
|
||||
| (Cmodi, _) ->
|
||||
(Iextcall(".rem", false), args)
|
||||
| _ ->
|
||||
raise Use_default
|
||||
|
||||
let select_store addr exp = raise Use_default
|
||||
|
||||
let select_push exp = fatal_error "Proc: select_push"
|
||||
|
||||
let pseudoregs_for_operation op arg res = raise Use_default
|
||||
|
||||
let word_addressed = false
|
||||
|
||||
(* Registers available for register allocation *)
|
||||
|
|
@ -227,8 +159,6 @@ let loc_external_arguments arg =
|
|||
done;
|
||||
(loc, Misc.align (!ofs + 4) 8) (* Keep stack 8-aligned *)
|
||||
|
||||
let extcall_use_push = false
|
||||
|
||||
let loc_external_results res =
|
||||
let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
|
||||
|
||||
|
|
@ -259,11 +189,6 @@ let max_register_pressure = function
|
|||
Iextcall(_, _) -> [| 11; 0 |]
|
||||
| _ -> [| 19; 15 |]
|
||||
|
||||
(* Reloading *)
|
||||
|
||||
let reload_test makereg round tst args = raise Use_default
|
||||
let reload_operation makereg round op args res = raise Use_default
|
||||
|
||||
(* Latencies (in cycles). Wild guesses. *)
|
||||
|
||||
let need_scheduling = true
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Reloading for the Sparc *)
|
||||
|
||||
let fundecl f =
|
||||
(new Reloadgen.reload_generic ())#fundecl f
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Mach
|
||||
|
||||
(* Instruction scheduling for the Sparc *)
|
||||
|
||||
class scheduler () as self =
|
||||
|
||||
inherit Schedgen.scheduler_generic () as super
|
||||
|
||||
(* Latencies (in cycles). Wild guesses. *)
|
||||
|
||||
method oper_latency = function
|
||||
Ireload -> 3
|
||||
| Iload(_, _) -> 3
|
||||
| Iconst_float _ -> 3 (* turned into a load *)
|
||||
| Iaddf | Isubf -> 3
|
||||
| Imulf -> 5
|
||||
| Idivf -> 15
|
||||
| _ -> 1
|
||||
|
||||
(* Issue cycles. Rough approximations. *)
|
||||
|
||||
method oper_issue_cycles = function
|
||||
Iconst_float _ -> 2
|
||||
| Iconst_symbol _ -> 2
|
||||
| Ialloc _ -> 6
|
||||
| Iintop(Icomp _) -> 4
|
||||
| Iintop(Icheckbound) -> 2
|
||||
| Iintop_imm(Idiv, _) -> 5
|
||||
| Iintop_imm(Imod, _) -> 5
|
||||
| Iintop_imm(Icomp _, _) -> 4
|
||||
| Iintop_imm(Icheckbound, _) -> 2
|
||||
| Inegf -> 2
|
||||
| Iabsf -> 2
|
||||
| Ifloatofint -> 6
|
||||
| Iintoffloat -> 6
|
||||
| _ -> 1
|
||||
|
||||
end
|
||||
|
||||
let fundecl f = (new scheduler ())#schedule_fundecl f
|
||||
|
||||
|
|
@ -0,0 +1,86 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1997 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Instruction selection for the Sparc processor *)
|
||||
|
||||
open Misc
|
||||
open Cmm
|
||||
open Reg
|
||||
open Arch
|
||||
open Mach
|
||||
|
||||
(* Recognition of addressing modes *)
|
||||
|
||||
type addressing_expr =
|
||||
Asymbol of string
|
||||
| Alinear of expression
|
||||
| Aadd of expression * expression
|
||||
|
||||
let rec select_addr = function
|
||||
Cconst_symbol s ->
|
||||
(Asymbol s, 0)
|
||||
| Cop((Caddi | Cadda), [arg; Cconst_int m]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Caddi | Cadda), [Cconst_int m; arg]) ->
|
||||
let (a, n) = select_addr arg in (a, n + m)
|
||||
| Cop((Caddi | Cadda), [arg1; arg2]) ->
|
||||
begin match (select_addr arg1, select_addr arg2) with
|
||||
((Alinear e1, n1), (Alinear e2, n2)) ->
|
||||
(Aadd(e1, e2), n1 + n2)
|
||||
| _ ->
|
||||
(Aadd(arg1, arg2), 0)
|
||||
end
|
||||
| exp ->
|
||||
(Alinear exp, 0)
|
||||
|
||||
class selector () as self =
|
||||
|
||||
inherit Selectgen.selector_generic() as super
|
||||
|
||||
method is_immediate n = (n <= 4095) && (n >= -4096)
|
||||
|
||||
method select_addressing exp =
|
||||
match select_addr exp with
|
||||
(Asymbol s, d) ->
|
||||
(Ibased(s, d), Ctuple [])
|
||||
| (Alinear e, d) ->
|
||||
(Iindexed d, e)
|
||||
| (Aadd(e1, e2), d) ->
|
||||
(Iindexed2 d, Ctuple[e1; e2])
|
||||
|
||||
method select_operation op args =
|
||||
match (op, args) with
|
||||
(* Multiplication, division and modulus are turned into
|
||||
calls to C library routines, except if the dividend is a power of 2. *)
|
||||
(Cmuli, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Ilsl, Misc.log2 n), [arg])
|
||||
| (Cmuli, [Cconst_int n; arg]) when n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Ilsl, Misc.log2 n), [arg])
|
||||
| (Cmuli, _) ->
|
||||
(Iextcall(".umul", false), args)
|
||||
| (Cdivi, [arg; Cconst_int n])
|
||||
when self#is_immediate n & n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Idiv, n), [arg])
|
||||
| (Cdivi, _) ->
|
||||
(Iextcall(".div", false), args)
|
||||
| (Cmodi, [arg; Cconst_int n])
|
||||
when self#is_immediate n & n = 1 lsl (Misc.log2 n) ->
|
||||
(Iintop_imm(Imod, n), [arg])
|
||||
| (Cmodi, _) ->
|
||||
(Iextcall(".rem", false), args)
|
||||
| _ ->
|
||||
super#select_operation op args
|
||||
|
||||
end
|
||||
|
||||
let fundecl f = (new selector ())#emit_fundecl f
|
||||
Loading…
Reference in New Issue