Populate tree.

1 files changed, 1184 insertions, 0 deletions

diff --git a/src/boot/be/macho.ml b/src/boot/be/macho.ml
new file mode 100644
index 00000000..7fccdfd3
--- /dev/null
+++ b/src/boot/be/macho.ml
@@ -0,0 +1,1184 @@
+open Asm;;
+open Common;;
+
+(* Mach-O writer. *)
+
+let log (sess:Session.sess) =
+  Session.log "obj (mach-o)"
+    sess.Session.sess_log_obj
+    sess.Session.sess_log_out
+;;
+
+let iflog (sess:Session.sess) (thunk:(unit -> unit)) : unit =
+  if sess.Session.sess_log_obj
+  then thunk ()
+  else ()
+;;
+
+let (cpu_arch_abi64:int64) = 0x01000000L
+;;
+
+let (mh_magic:int64) = 0xfeedfaceL
+;;
+
+let cpu_subtype_intel (f:int64) (m:int64) : int64 =
+  Int64.add f (Int64.shift_left m 4)
+;;
+
+type cpu_type =
+    (* Maybe support more later. *)
+    CPU_TYPE_X86
+  | CPU_TYPE_X86_64
+  | CPU_TYPE_ARM
+  | CPU_TYPE_POWERPC
+;;
+
+type cpu_subtype =
+    (* Maybe support more later. *)
+    CPU_SUBTYPE_X86_ALL
+  | CPU_SUBTYPE_X86_64_ALL
+  | CPU_SUBTYPE_ARM_ALL
+  | CPU_SUBTYPE_POWERPC_ALL
+;;
+
+type file_type =
+    MH_OBJECT
+  | MH_EXECUTE
+  | MH_FVMLIB
+  | MH_CORE
+  | MH_PRELOAD
+  | MH_DYLIB
+  | MH_DYLINKER
+  | MH_BUNDLE
+  | MH_DYLIB_STUB
+  | MH_DSYM
+;;
+
+let file_type_code (ft:file_type) : int64 =
+  match ft with
+      MH_OBJECT ->0x1L      (* object *)
+    | MH_EXECUTE -> 0x2L    (* executable *)
+    | MH_FVMLIB -> 0x3L     (* fixed-VM shared lib *)
+    | MH_CORE -> 0x4L       (* core *)
+    | MH_PRELOAD -> 0x5L    (* preloaded executable *)
+    | MH_DYLIB -> 0x6L      (* dynamic lib *)
+    | MH_DYLINKER -> 0x7L   (* dynamic linker *)
+    | MH_BUNDLE -> 0x8L     (* bundle *)
+    | MH_DYLIB_STUB -> 0x9L (* shared lib stub *)
+    | MH_DSYM -> 0xaL       (* debuginfo only *)
+;;
+
+type file_flag =
+    MH_NOUNDEFS
+  | MH_INCRLINK
+  | MH_DYLDLINK
+  | MH_BINDATLOAD
+  | MH_PREBOUND
+  | MH_SPLIT_SEGS
+  | MH_LAZY_INIT
+  | MH_TWOLEVEL
+  | MH_FORCE_FLAT
+  | MH_NOMULTIDEFS
+  | MH_NOFIXPREBINDING
+  | MH_PREBINDABLE
+  | MH_ALLMODSBOUND
+  | MH_SUBSECTIONS_VIA_SYMBOLS
+  | MH_CANONICAL
+  | MH_WEAK_DEFINES
+  | MH_BINDS_TO_WEAK
+  | MH_ALLOW_STACK_EXECUTION
+  | MH_ROOT_SAFE
+  | MH_SETUID_SAFE
+  | MH_NO_REEXPORTED_DYLIBS
+  | MH_PIE
+;;
+
+let file_flag_code (ff:file_flag) : int64 =
+  match ff with
+      MH_NOUNDEFS -> 0x1L
+    | MH_INCRLINK -> 0x2L
+    | MH_DYLDLINK -> 0x4L
+    | MH_BINDATLOAD -> 0x8L
+    | MH_PREBOUND -> 0x10L
+    | MH_SPLIT_SEGS -> 0x20L
+    | MH_LAZY_INIT -> 0x40L
+    | MH_TWOLEVEL -> 0x80L
+    | MH_FORCE_FLAT -> 0x100L
+    | MH_NOMULTIDEFS -> 0x200L
+    | MH_NOFIXPREBINDING -> 0x400L
+    | MH_PREBINDABLE -> 0x800L
+    | MH_ALLMODSBOUND -> 0x1000L
+    | MH_SUBSECTIONS_VIA_SYMBOLS -> 0x2000L
+    | MH_CANONICAL -> 0x4000L
+    | MH_WEAK_DEFINES -> 0x8000L
+    | MH_BINDS_TO_WEAK -> 0x10000L
+    | MH_ALLOW_STACK_EXECUTION -> 0x20000L
+    | MH_ROOT_SAFE -> 0x40000L
+    | MH_SETUID_SAFE -> 0x80000L
+    | MH_NO_REEXPORTED_DYLIBS -> 0x100000L
+    | MH_PIE -> 0x200000L
+;;
+
+
+type vm_prot =
+    VM_PROT_NONE
+  | VM_PROT_READ
+  | VM_PROT_WRITE
+  | VM_PROT_EXECUTE
+;;
+
+
+type load_command =
+    LC_SEGMENT
+  | LC_SYMTAB
+  | LC_SYMSEG
+  | LC_THREAD
+  | LC_UNIXTHREAD
+  | LC_LOADFVMLIB
+  | LC_IDFVMLIB
+  | LC_IDENT
+  | LC_FVMFILE
+  | LC_PREPAGE
+  | LC_DYSYMTAB
+  | LC_LOAD_DYLIB
+  | LC_ID_DYLIB
+  | LC_LOAD_DYLINKER
+  | LC_ID_DYLINKER
+  | LC_PREBOUND_DYLIB
+  | LC_ROUTINES
+  | LC_SUB_FRAMEWORK
+  | LC_SUB_UMBRELLA
+  | LC_SUB_CLIENT
+  | LC_SUB_LIBRARY
+  | LC_TWOLEVEL_HINTS
+  | LC_PREBIND_CKSUM
+  | LC_LOAD_WEAK_DYLIB
+  | LC_SEGMENT_64
+  | LC_ROUTINES_64
+  | LC_UUID
+  | LC_RPATH
+  | LC_CODE_SIGNATURE
+  | LC_SEGMENT_SPLIT_INFO
+  | LC_REEXPORT_DYLIB
+  | LC_LAZY_LOAD_DYLIB
+  | LC_ENCRYPTION_INFO
+;;
+
+
+let cpu_type_code (cpu:cpu_type) : int64 =
+  match cpu with
+      CPU_TYPE_X86 -> 7L
+    | CPU_TYPE_X86_64 -> Int64.logor 7L cpu_arch_abi64
+    | CPU_TYPE_ARM -> 12L
+    | CPU_TYPE_POWERPC -> 18L
+;;
+
+let cpu_subtype_code (cpu:cpu_subtype) : int64 =
+  match cpu with
+      CPU_SUBTYPE_X86_ALL -> 3L
+    | CPU_SUBTYPE_X86_64_ALL -> 3L
+    | CPU_SUBTYPE_ARM_ALL -> 0L
+    | CPU_SUBTYPE_POWERPC_ALL -> 0L
+;;
+
+
+let vm_prot_code (vmp:vm_prot) : int64 =
+  match vmp with
+    VM_PROT_NONE -> 0L
+  | VM_PROT_READ -> 1L
+  | VM_PROT_WRITE -> 2L
+  | VM_PROT_EXECUTE -> 4L
+;;
+
+
+let lc_req_dyld = 0x80000000L;;
+
+let load_command_code (lc:load_command) =
+  match lc with
+    | LC_SEGMENT -> 0x1L
+    | LC_SYMTAB -> 0x2L
+    | LC_SYMSEG -> 0x3L
+    | LC_THREAD -> 0x4L
+    | LC_UNIXTHREAD -> 0x5L
+    | LC_LOADFVMLIB -> 0x6L
+    | LC_IDFVMLIB -> 0x7L
+    | LC_IDENT -> 0x8L
+    | LC_FVMFILE -> 0x9L
+    | LC_PREPAGE -> 0xaL
+    | LC_DYSYMTAB -> 0xbL
+    | LC_LOAD_DYLIB -> 0xcL
+    | LC_ID_DYLIB -> 0xdL
+    | LC_LOAD_DYLINKER -> 0xeL
+    | LC_ID_DYLINKER -> 0xfL
+    | LC_PREBOUND_DYLIB -> 0x10L
+    | LC_ROUTINES -> 0x11L
+    | LC_SUB_FRAMEWORK -> 0x12L
+    | LC_SUB_UMBRELLA -> 0x13L
+    | LC_SUB_CLIENT -> 0x14L
+    | LC_SUB_LIBRARY -> 0x15L
+    | LC_TWOLEVEL_HINTS -> 0x16L
+    | LC_PREBIND_CKSUM -> 0x17L
+    | LC_LOAD_WEAK_DYLIB -> Int64.logor lc_req_dyld 0x18L
+    | LC_SEGMENT_64 -> 0x19L
+    | LC_ROUTINES_64 -> 0x1aL
+    | LC_UUID -> 0x1bL
+    | LC_RPATH -> Int64.logor lc_req_dyld 0x1cL
+    | LC_CODE_SIGNATURE -> 0x1dL
+    | LC_SEGMENT_SPLIT_INFO -> 0x1eL
+    | LC_REEXPORT_DYLIB -> Int64.logor lc_req_dyld 0x1fL
+    | LC_LAZY_LOAD_DYLIB -> 0x20L
+    | LC_ENCRYPTION_INFO -> 0x21L
+;;
+
+
+let fixed_sz_string (sz:int) (str:string) : frag =
+  if String.length str > sz
+  then STRING (String.sub str 0 sz)
+  else SEQ [| STRING str; PAD (sz - (String.length str)) |]
+;;
+
+type sect_type =
+    S_REGULAR
+  | S_ZEROFILL
+  | S_CSTRING_LITERALS
+  | S_4BYTE_LITERALS
+  | S_8BYTE_LITERALS
+  | S_LITERAL_POINTERS
+  | S_NON_LAZY_SYMBOL_POINTERS
+  | S_LAZY_SYMBOL_POINTERS
+  | S_SYMBOL_STUBS
+  | S_MOD_INIT_FUNC_POINTERS
+  | S_MOD_TERM_FUNC_POINTERS
+  | S_COALESCED
+  | S_GB_ZEROFILL
+  | S_INTERPOSING
+  | S_16BYTE_LITERALS
+  | S_DTRACE_DOF
+  | S_LAZY_DYLIB_SYMBOL_POINTERS
+;;
+
+let sect_type_code (s:sect_type) : int64 =
+  match s with
+    S_REGULAR -> 0x0L
+  | S_ZEROFILL -> 0x1L
+  | S_CSTRING_LITERALS -> 0x2L
+  | S_4BYTE_LITERALS -> 0x3L
+  | S_8BYTE_LITERALS -> 0x4L
+  | S_LITERAL_POINTERS -> 0x5L
+  | S_NON_LAZY_SYMBOL_POINTERS -> 0x6L
+  | S_LAZY_SYMBOL_POINTERS -> 0x7L
+  | S_SYMBOL_STUBS -> 0x8L
+  | S_MOD_INIT_FUNC_POINTERS -> 0x9L
+  | S_MOD_TERM_FUNC_POINTERS -> 0xaL
+  | S_COALESCED -> 0xbL
+  | S_GB_ZEROFILL -> 0xcL
+  | S_INTERPOSING -> 0xdL
+  | S_16BYTE_LITERALS -> 0xeL
+  | S_DTRACE_DOF -> 0xfL
+  | S_LAZY_DYLIB_SYMBOL_POINTERS -> 0x10L
+;;
+
+type sect_attr =
+    S_ATTR_PURE_INSTRUCTIONS
+  | S_ATTR_NO_TOC
+  | S_ATTR_STRIP_STATIC_SYMS
+  | S_ATTR_NO_DEAD_STRIP
+  | S_ATTR_LIVE_SUPPORT
+  | S_ATTR_SELF_MODIFYING_CODE
+  | S_ATTR_DEBUG
+  | S_ATTR_SOME_INSTRUCTIONS
+  | S_ATTR_EXT_RELOC
+  | S_ATTR_LOC_RELOC
+;;
+
+let sect_attr_code (s:sect_attr) : int64 =
+  match s with
+    S_ATTR_PURE_INSTRUCTIONS -> 0x80000000L
+  | S_ATTR_NO_TOC -> 0x40000000L
+  | S_ATTR_STRIP_STATIC_SYMS -> 0x20000000L
+  | S_ATTR_NO_DEAD_STRIP -> 0x10000000L
+  | S_ATTR_LIVE_SUPPORT -> 0x08000000L
+  | S_ATTR_SELF_MODIFYING_CODE -> 0x04000000L
+  | S_ATTR_DEBUG -> 0x02000000L
+  | S_ATTR_SOME_INSTRUCTIONS -> 0x00000400L
+  | S_ATTR_EXT_RELOC -> 0x00000200L
+  | S_ATTR_LOC_RELOC -> 0x00000100L
+;;
+
+type n_type =
+  | N_EXT
+  | N_UNDF
+  | N_ABS
+  | N_SECT
+  | N_PBUD
+  | N_INDIR
+;;
+
+let n_type_code (n:n_type) : int64 =
+  match n with
+      N_EXT -> 0x1L
+    | N_UNDF -> 0x0L
+    | N_ABS -> 0x2L
+    | N_SECT -> 0xeL
+    | N_PBUD -> 0xcL
+    | N_INDIR -> 0xaL
+;;
+
+
+type n_desc_reference_type =
+    REFERENCE_FLAG_UNDEFINED_NON_LAZY
+  | REFERENCE_FLAG_UNDEFINED_LAZY
+  | REFERENCE_FLAG_DEFINED
+  | REFERENCE_FLAG_PRIVATE_DEFINED
+  | REFERENCE_FLAG_PRIVATE_UNDEFINED_NON_LAZY
+  | REFERENCE_FLAG_PRIVATE_UNDEFINED_LAZY
+;;
+
+let n_desc_reference_type_code (n:n_desc_reference_type) : int64 =
+  match n with
+      REFERENCE_FLAG_UNDEFINED_NON_LAZY -> 0x0L
+    | REFERENCE_FLAG_UNDEFINED_LAZY -> 0x1L
+    | REFERENCE_FLAG_DEFINED -> 0x2L
+    | REFERENCE_FLAG_PRIVATE_DEFINED -> 0x3L
+    | REFERENCE_FLAG_PRIVATE_UNDEFINED_NON_LAZY -> 0x4L
+    | REFERENCE_FLAG_PRIVATE_UNDEFINED_LAZY -> 0x5L
+;;
+
+type n_desc_flags =
+    REFERENCED_DYNAMICALLY
+  | N_DESC_DISCARDED
+  | N_NO_DEAD_STRIP
+  | N_WEAK_REF
+  | N_WEAK_DEF
+;;
+
+let n_desc_flags_code (n:n_desc_flags) : int64 =
+  match n with
+      REFERENCED_DYNAMICALLY -> 0x10L
+    | N_DESC_DISCARDED -> 0x20L
+    | N_NO_DEAD_STRIP -> 0x20L (* Yes, they reuse 0x20. *)
+    | N_WEAK_REF -> 0x40L
+    | N_WEAK_DEF -> 0x80L
+;;
+
+type n_desc_dylib_ordinal = int;;
+
+type n_desc = (n_desc_dylib_ordinal *
+                 (n_desc_flags list) *
+                 n_desc_reference_type)
+;;
+
+let n_desc_code (n:n_desc) : int64 =
+  let (dylib_ordinal, flags, ty) = n in
+    Int64.logor
+      (Int64.of_int (dylib_ordinal lsl 8))
+      (Int64.logor
+         (fold_flags n_desc_flags_code flags)
+         (n_desc_reference_type_code ty))
+;;
+
+
+let macho_section_command
+    (seg_name:string)
+    (sect:(string * int * (sect_attr list) * sect_type * fixup))
+    : frag =
+  let (sect_name, sect_align, sect_attrs, sect_type, sect_fixup) = sect in
+    SEQ [|
+      fixed_sz_string 16 sect_name;
+      fixed_sz_string 16 seg_name;
+      WORD (TY_u32, M_POS sect_fixup);
+      WORD (TY_u32, M_SZ sect_fixup);
+      WORD (TY_u32, F_POS sect_fixup);
+      WORD (TY_u32, IMM (Int64.of_int sect_align));
+      WORD (TY_u32, IMM 0L); (* reloff *)
+      WORD (TY_u32, IMM 0L); (* nreloc *)
+      WORD (TY_u32, (IMM (Int64.logor (* flags (and attrs) *)
+                            (fold_flags sect_attr_code sect_attrs)
+                            (sect_type_code sect_type))));
+      WORD (TY_u32, IMM 0L); (* reserved1 *)
+      WORD (TY_u32, IMM 0L); (* reserved2 *)
+  |]
+;;
+
+let macho_segment_command
+    (seg_name:string)
+    (seg_fixup:fixup)
+    (maxprot:vm_prot list)
+    (initprot:vm_prot list)
+    (sects:(string * int * (sect_attr list) * sect_type * fixup) array)
+    : frag =
+
+  let cmd_fixup = new_fixup "segment command" in
+  let cmd =
+    SEQ [|
+      WORD (TY_u32, IMM (load_command_code LC_SEGMENT));
+      WORD (TY_u32, F_SZ cmd_fixup);
+      fixed_sz_string 16 seg_name;
+      WORD (TY_u32, M_POS seg_fixup);
+      WORD (TY_u32, M_SZ seg_fixup);
+      WORD (TY_u32, F_POS seg_fixup);
+      WORD (TY_u32, F_SZ seg_fixup);
+      WORD (TY_u32, IMM (fold_flags vm_prot_code maxprot));
+      WORD (TY_u32, IMM (fold_flags vm_prot_code initprot));
+      WORD (TY_u32, IMM (Int64.of_int (Array.length sects)));
+      WORD (TY_u32, IMM 0L); (* Flags? *)
+    |]
+  in
+    DEF (cmd_fixup,
+         SEQ [|
+           cmd;
+           SEQ (Array.map (macho_section_command seg_name) sects);
+         |])
+;;
+
+let macho_thread_command
+    (entry:fixup)
+    : frag =
+  let cmd_fixup = new_fixup "thread command" in
+  let x86_THREAD_STATE32 = 1L in
+  let regs =
+    [|
+      WORD (TY_u32, IMM 0x0L); (* eax *)
+      WORD (TY_u32, IMM 0x0L); (* ebx *)
+      WORD (TY_u32, IMM 0x0L); (* ecx *)
+      WORD (TY_u32, IMM 0x0L); (* edx *)
+
+      WORD (TY_u32, IMM 0x0L); (* edi *)
+      WORD (TY_u32, IMM 0x0L); (* esi *)
+      WORD (TY_u32, IMM 0x0L); (* ebp *)
+      WORD (TY_u32, IMM 0x0L); (* esp *)
+
+      WORD (TY_u32, IMM 0x0L);    (* ss     *)
+      WORD (TY_u32, IMM 0x0L);    (* eflags *)
+      WORD (TY_u32, M_POS entry); (* eip    *)
+      WORD (TY_u32, IMM 0x0L);    (* cs     *)
+
+      WORD (TY_u32, IMM 0x0L); (* ds *)
+      WORD (TY_u32, IMM 0x0L); (* es *)
+      WORD (TY_u32, IMM 0x0L); (* fs *)
+      WORD (TY_u32, IMM 0x0L); (* gs *)
+    |]
+  in
+  let cmd =
+    SEQ [|
+      WORD (TY_u32, IMM (load_command_code LC_UNIXTHREAD));
+      WORD (TY_u32, F_SZ cmd_fixup);
+      WORD (TY_u32, IMM x86_THREAD_STATE32); (* "flavour" *)
+      WORD (TY_u32, IMM (Int64.of_int (Array.length regs)));
+      SEQ regs
+    |]
+  in
+    DEF (cmd_fixup, cmd)
+;;
+
+let macho_dylinker_command : frag =
+  let cmd_fixup = new_fixup "dylinker command" in
+  let str_fixup = new_fixup "dylinker lc_str fixup" in
+  let cmd =
+    SEQ
+      [|
+        WORD (TY_u32, IMM (load_command_code LC_LOAD_DYLINKER));
+        WORD (TY_u32, F_SZ cmd_fixup);
+
+        (* see definition of lc_str; these things are weird. *)
+        WORD (TY_u32, SUB (F_POS (str_fixup), F_POS (cmd_fixup)));
+        DEF (str_fixup, ZSTRING "/usr/lib/dyld");
+        ALIGN_FILE (4, MARK);
+      |]
+  in
+    DEF (cmd_fixup, cmd);
+;;
+
+let macho_dylib_command (dylib:string) : frag =
+
+  let cmd_fixup = new_fixup "dylib command" in
+  let str_fixup = new_fixup "dylib lc_str fixup" in
+  let cmd =
+    SEQ
+      [|
+        WORD (TY_u32, IMM (load_command_code LC_LOAD_DYLIB));
+        WORD (TY_u32, F_SZ cmd_fixup);
+
+        (* see definition of lc_str; these things are weird. *)
+        WORD (TY_u32, SUB (F_POS (str_fixup), F_POS (cmd_fixup)));
+
+        WORD (TY_u32, IMM 0L); (* timestamp *)
+        WORD (TY_u32, IMM 0L); (* current_version *)
+        WORD (TY_u32, IMM 0L); (* compatibility_version *)
+
+        (* Payload-and-alignment of an lc_str goes at end of command. *)
+        DEF (str_fixup, ZSTRING dylib);
+        ALIGN_FILE (4, MARK);
+
+      |]
+  in
+    DEF (cmd_fixup, cmd)
+;;
+
+
+let macho_symtab_command
+    (symtab_fixup:fixup)
+    (nsyms:int64)
+    (strtab_fixup:fixup)
+    : frag =
+  let cmd_fixup = new_fixup "symtab command" in
+  let cmd =
+    SEQ
+      [|
+        WORD (TY_u32, IMM (load_command_code LC_SYMTAB));
+        WORD (TY_u32, F_SZ cmd_fixup);
+
+        WORD (TY_u32, F_POS symtab_fixup); (* symoff *)
+        WORD (TY_u32, IMM nsyms);          (* nsyms *)
+
+        WORD (TY_u32, F_POS strtab_fixup); (* stroff *)
+        WORD (TY_u32, F_SZ strtab_fixup);  (* strsz *)
+      |]
+  in
+    DEF (cmd_fixup, cmd)
+;;
+
+let macho_dysymtab_command
+    (local_defined_syms_index:int64)
+    (local_defined_syms_count:int64)
+    (external_defined_syms_index:int64)
+    (external_defined_syms_count:int64)
+    (undefined_syms_index:int64)
+    (undefined_syms_count:int64)
+    (indirect_symtab_fixup:fixup)  : frag =
+  let cmd_fixup = new_fixup "dysymtab command" in
+  let cmd =
+    SEQ
+      [|
+        WORD (TY_u32, IMM (load_command_code LC_DYSYMTAB));
+        WORD (TY_u32, F_SZ cmd_fixup);
+
+        WORD (TY_u32, IMM local_defined_syms_index); (* ilocalsym *)
+        WORD (TY_u32, IMM local_defined_syms_count); (* nlocalsym *)
+
+        WORD (TY_u32, IMM external_defined_syms_index); (* iextdefsym *)
+        WORD (TY_u32, IMM external_defined_syms_count); (* nextdefsym *)
+
+        WORD (TY_u32, IMM undefined_syms_index); (* iundefsym *)
+        WORD (TY_u32, IMM undefined_syms_count); (* nundefsym *)
+
+        WORD (TY_u32, IMM 0L); (* tocoff *)
+        WORD (TY_u32, IMM 0L); (* ntoc *)
+
+        WORD (TY_u32, IMM 0L); (* modtaboff *)
+        WORD (TY_u32, IMM 0L); (* nmodtab *)
+
+        WORD (TY_u32, IMM 0L); (* extrefsymoff *)
+        WORD (TY_u32, IMM 0L); (* nextrefsyms *)
+
+        WORD (TY_u32, F_POS indirect_symtab_fixup); (* indirectsymoff *)
+        WORD (TY_u32, IMM undefined_syms_count);    (* nindirectsyms *)
+
+        WORD (TY_u32, IMM 0L); (* extreloff *)
+        WORD (TY_u32, IMM 0L); (* nextrel *)
+
+        WORD (TY_u32, IMM 0L); (* locreloff *)
+        WORD (TY_u32, IMM 0L); (* nlocrel *)
+      |]
+  in
+    DEF (cmd_fixup, cmd)
+;;
+
+let macho_header_32
+    (cpu:cpu_type)
+    (sub:cpu_subtype)
+    (ftype:file_type)
+    (flags:file_flag list)
+    (loadcmds:frag array) : frag =
+  let load_commands_fixup = new_fixup "load commands" in
+  let cmds = DEF (load_commands_fixup, SEQ loadcmds) in
+    SEQ
+    [|
+      WORD (TY_u32, IMM mh_magic);
+      WORD (TY_u32, IMM (cpu_type_code cpu));
+      WORD (TY_u32, IMM (cpu_subtype_code sub));
+      WORD (TY_u32, IMM (file_type_code ftype));
+      WORD (TY_u32, IMM (Int64.of_int (Array.length loadcmds)));
+      WORD (TY_u32, F_SZ load_commands_fixup);
+      WORD (TY_u32, IMM (fold_flags file_flag_code flags));
+      cmds
+    |]
+;;
+
+let emit_file
+    (sess:Session.sess)
+    (crate:Ast.crate)
+    (code:Asm.frag)
+    (data:Asm.frag)
+    (sem:Semant.ctxt)
+    (dwarf:Dwarf.debug_records)
+    : unit =
+
+  (* FIXME: alignment? *)
+
+  let mh_execute_header_fixup = new_fixup "__mh_execute header" in
+
+  let nxargc_fixup = (Semant.provide_native sem SEG_data "NXArgc") in
+  let nxargv_fixup = (Semant.provide_native sem SEG_data "NXArgv") in
+  let progname_fixup = (Semant.provide_native sem SEG_data "__progname") in
+  let environ_fixup = (Semant.provide_native sem SEG_data "environ") in
+  let exit_fixup = (Semant.require_native sem REQUIRED_LIB_crt "exit") in
+  let (start_fixup, rust_start_fixup) =
+    if sess.Session.sess_library_mode
+    then (None, None)
+    else (Some (new_fixup "start function entry"),
+          Some (Semant.require_native sem REQUIRED_LIB_rustrt "rust_start"))
+  in
+
+  let text_sect_align_log2 = 2 in
+  let data_sect_align_log2 = 2 in
+
+  let seg_align = 0x1000 in
+  let text_sect_align = 2 lsl text_sect_align_log2 in
+  let data_sect_align = 2 lsl data_sect_align_log2 in
+
+  let align_both align i =
+    ALIGN_FILE (align,
+                (ALIGN_MEM (align, i)))
+  in
+
+  let def_aligned a f i =
+    align_both a
+      (SEQ [| DEF(f, i);
+              (align_both a MARK)|])
+  in
+
+  (* Segments. *)
+  let zero_segment_fixup = new_fixup "__PAGEZERO segment" in
+  let text_segment_fixup = new_fixup "__TEXT segment" in
+  let data_segment_fixup = new_fixup "__DATA segment" in
+  let dwarf_segment_fixup = new_fixup "__DWARF segment" in
+  let linkedit_segment_fixup = new_fixup "__LINKEDIT segment" in
+
+  (* Sections in the text segment. *)
+  let text_section_fixup = new_fixup "__text section" in
+
+  (* Sections in the data segment. *)
+  let data_section_fixup = new_fixup "__data section" in
+  let const_section_fixup = new_fixup "__const section" in
+  let bss_section_fixup = new_fixup "__bss section" in
+  let note_rust_section_fixup = new_fixup "__note.rust section" in
+  let nl_symbol_ptr_section_fixup = new_fixup "__nl_symbol_ptr section" in
+
+  let data_section = def_aligned data_sect_align data_section_fixup data in
+  let const_section =
+    def_aligned data_sect_align const_section_fixup (SEQ [| |])
+  in
+  let bss_section =
+    def_aligned data_sect_align bss_section_fixup (SEQ [| |])
+  in
+  let note_rust_section =
+    def_aligned
+      data_sect_align note_rust_section_fixup
+      (Asm.note_rust_frags crate.node.Ast.crate_meta)
+  in
+
+  (* Officially Apple doesn't claim to support DWARF sections like this, but
+     they work. *)
+  let debug_info_section =
+    def_aligned data_sect_align
+      sem.Semant.ctxt_debug_info_fixup
+      dwarf.Dwarf.debug_info
+  in
+  let debug_abbrev_section =
+    def_aligned data_sect_align
+      sem.Semant.ctxt_debug_abbrev_fixup
+      dwarf.Dwarf.debug_abbrev
+  in
+
+
+  (* String, symbol and parallel "nonlazy-pointer" tables. *)
+  let symtab_fixup = new_fixup "symtab" in
+  let strtab_fixup = new_fixup "strtab" in
+
+  let symbol_nlist_entry
+      (sect_index:int)
+      (nty:n_type list)
+      (nd:n_desc)
+      (nv:Asm.expr64)
+      : (frag * fixup) =
+    let strtab_entry_fixup = new_fixup "strtab entry" in
+      (SEQ
+         [|
+           WORD (TY_u32, SUB ((F_POS strtab_entry_fixup),
+                              (F_POS strtab_fixup)));
+           BYTE (Int64.to_int (fold_flags n_type_code nty));
+           BYTE sect_index;
+           WORD (TY_u16, IMM (n_desc_code nd));
+           WORD (TY_u32, nv);
+         |], strtab_entry_fixup)
+  in
+
+  let sect_symbol_nlist_entry
+      (seg:segment)
+      (fixup_to_use:fixup)
+      : (frag * fixup) =
+    let nty = [ N_SECT; N_EXT ] in
+    let nd = (0, [], REFERENCE_FLAG_UNDEFINED_NON_LAZY) in
+    let (sect_index, _(*seg_fix*)) =
+      match seg with
+          SEG_text -> (1, text_segment_fixup)
+        | SEG_data -> (2, data_segment_fixup)
+    in
+      symbol_nlist_entry sect_index nty nd (M_POS fixup_to_use)
+  in
+
+  let sect_private_symbol_nlist_entry
+      (seg:segment)
+      (fixup_to_use:fixup)
+      : (frag * fixup) =
+    let nty = [ N_SECT; ] in
+    let nd = (0, [], REFERENCE_FLAG_UNDEFINED_NON_LAZY) in
+    let (sect_index, _(*seg_fix*)) =
+      match seg with
+          SEG_text -> (1, text_segment_fixup)
+        | SEG_data -> (2, data_segment_fixup)
+    in
+      symbol_nlist_entry sect_index nty nd (M_POS fixup_to_use)
+  in
+
+  let indirect_symbol_nlist_entry (dylib_index:int) : (frag * fixup) =
+    let nty = [ N_UNDF; N_EXT ] in
+    let nd = (dylib_index, [], REFERENCE_FLAG_UNDEFINED_NON_LAZY) in
+      symbol_nlist_entry 0 nty nd (IMM 0L)
+  in
+
+  let indirect_symbols =
+    Array.of_list
+      (List.concat
+         (List.map
+            (fun (lib, tab) ->
+               (List.map
+                  (fun (name,fix) -> (lib,name,fix))
+                  (htab_pairs tab)))
+            (htab_pairs sem.Semant.ctxt_native_required)))
+  in
+
+  let dylib_index (lib:required_lib) : int =
+    match lib with
+        REQUIRED_LIB_rustrt -> 1
+      | REQUIRED_LIB_crt -> 2
+      | _ -> bug () "Macho.dylib_index on nonstandard required lib."
+  in
+
+  (* Make undef symbols for native imports. *)
+  let (undefined_symbols:(string * (frag * fixup)) array) =
+    Array.map (fun (lib,name,_) ->
+                 ("_" ^ name,
+                  indirect_symbol_nlist_entry (dylib_index lib)))
+      indirect_symbols
+  in
+
+  (* Make symbols for exports. *)
+  let (export_symbols:(string * (frag * fixup)) array) =
+    let export_symbols_of_seg (seg, tab) =
+      List.map
+        begin
+          fun (name, fix) ->
+            let name = "_" ^ name in
+            let sym = sect_symbol_nlist_entry seg fix in
+              (name, sym)
+        end
+        (htab_pairs tab)
+    in
+      Array.of_list
+        (List.concat
+           (List.map export_symbols_of_seg
+              (htab_pairs sem.Semant.ctxt_native_provided)))
+  in
+
+  (* Make private symbols for items. *)
+  let (local_item_symbols:(string * (frag * fixup)) array) =
+    Array.map (fun code ->
+                 let fix = code.Semant.code_fixup in
+                   ("_" ^ fix.fixup_name,
+                    sect_private_symbol_nlist_entry SEG_text fix))
+      (Array.of_list (htab_vals sem.Semant.ctxt_all_item_code))
+  in
+
+  (* Make private symbols for glue. *)
+  let (local_glue_symbols:(string * (frag * fixup)) array) =
+    Array.map (fun (g, code) ->
+                 let fix = code.Semant.code_fixup in
+                   ("_" ^ (Semant.glue_str sem g),
+                    sect_private_symbol_nlist_entry SEG_text fix))
+      (Array.of_list (htab_pairs sem.Semant.ctxt_glue_code))
+  in
+
+  let (export_header_symbols:(string * (frag * fixup)) array) =
+    let name =
+      if sess.Session.sess_library_mode
+      then "__mh_dylib_header"
+      else "__mh_execute_header"
+    in
+      [|
+        (name, sect_symbol_nlist_entry SEG_text mh_execute_header_fixup);
+      |]
+  in
+
+  let export_symbols = Array.concat [ export_symbols;
+                                      export_header_symbols ]
+  in
+
+  let local_symbols = Array.concat [ local_item_symbols;
+                                     local_glue_symbols ]
+  in
+
+  let symbols = Array.concat [ local_symbols;
+                               export_symbols;
+                               undefined_symbols ]
+  in
+  let n_local_syms = Array.length local_symbols in
+  let n_export_syms = Array.length export_symbols in
+  let n_undef_syms = Array.length undefined_symbols in
+
+  let indirect_symbols_off = n_local_syms + n_export_syms in
+  let indirect_symtab_fixup = new_fixup "indirect symbol table" in
+  let indirect_symtab =
+    DEF (indirect_symtab_fixup,
+         SEQ (Array.mapi
+                (fun i _ -> WORD (TY_u32,
+                                  IMM (Int64.of_int
+                                         (i + indirect_symbols_off))))
+                indirect_symbols))
+  in
+
+  let nl_symbol_ptr_section =
+    def_aligned data_sect_align nl_symbol_ptr_section_fixup
+      (SEQ (Array.map
+              (fun (_, _, fix) ->
+                 DEF(fix, WORD(TY_u32, IMM 0L)))
+              indirect_symbols))
+  in
+  let strtab = DEF (strtab_fixup,
+                    SEQ (Array.map
+                           (fun (name, (_, fix)) -> DEF(fix, ZSTRING name))
+                           symbols))
+  in
+  let symtab = DEF (symtab_fixup,
+                    SEQ (Array.map (fun (_, (frag, _)) -> frag) symbols))
+  in
+
+
+  let load_commands =
+    [|
+      macho_segment_command "__PAGEZERO" zero_segment_fixup
+        [] [] [||];
+
+      macho_segment_command "__TEXT" text_segment_fixup
+        [VM_PROT_READ; VM_PROT_EXECUTE]
+        [VM_PROT_READ; VM_PROT_EXECUTE]
+        [|
+          ("__text", text_sect_align_log2, [], S_REGULAR, text_section_fixup)
+        |];
+
+      macho_segment_command "__DATA" data_segment_fixup
+        [VM_PROT_READ; VM_PROT_WRITE]
+        [VM_PROT_READ; VM_PROT_WRITE]
+        [|
+          ("__data", data_sect_align_log2, [],
+           S_REGULAR, data_section_fixup);
+          ("__const", data_sect_align_log2, [],
+           S_REGULAR, const_section_fixup);
+          ("__bss", data_sect_align_log2, [],
+           S_REGULAR, bss_section_fixup);
+          ("__note.rust", data_sect_align_log2, [],
+           S_REGULAR, note_rust_section_fixup);
+          ("__nl_symbol_ptr", data_sect_align_log2, [],
+           S_NON_LAZY_SYMBOL_POINTERS, nl_symbol_ptr_section_fixup)
+        |];
+
+      macho_segment_command "__DWARF" dwarf_segment_fixup
+        [VM_PROT_READ]
+        [VM_PROT_READ]
+        [|
+          ("__debug_info", data_sect_align_log2, [],
+           S_REGULAR, sem.Semant.ctxt_debug_info_fixup);
+          ("__debug_abbrev", data_sect_align_log2, [],
+           S_REGULAR, sem.Semant.ctxt_debug_abbrev_fixup);
+        |];
+
+      macho_segment_command "__LINKEDIT" linkedit_segment_fixup
+        [VM_PROT_READ]
+        [VM_PROT_READ]
+        [|
+        |];
+
+      macho_symtab_command
+        symtab_fixup (Int64.of_int (Array.length symbols)) strtab_fixup;
+
+
+      macho_dysymtab_command
+        0L
+        (Int64.of_int n_local_syms)
+        (Int64.of_int n_local_syms)
+        (Int64.of_int n_export_syms)
+        (Int64.of_int (n_local_syms + n_export_syms))
+        (Int64.of_int n_undef_syms)
+        indirect_symtab_fixup;
+
+      macho_dylinker_command;
+
+      macho_dylib_command "librustrt.dylib";
+
+      macho_dylib_command "/usr/lib/libSystem.B.dylib";
+
+      begin
+        match start_fixup with
+            None -> MARK
+          | Some start_fixup ->
+              macho_thread_command start_fixup
+      end;
+    |]
+  in
+
+  let header_and_commands =
+    macho_header_32
+      CPU_TYPE_X86
+      CPU_SUBTYPE_X86_ALL
+      (if sess.Session.sess_library_mode then MH_DYLIB else MH_EXECUTE)
+      [ MH_BINDATLOAD; MH_DYLDLINK; MH_TWOLEVEL ]
+      load_commands
+  in
+
+  let objfile_start e start_fixup rust_start_fixup main_fn_fixup =
+    let edx = X86.h X86.edx in
+    let edx_pointee =
+      Il.Mem ((Il.RegIn (edx, None)), Il.ScalarTy (Il.AddrTy Il.OpaqueTy))
+    in
+      Il.emit_full e (Some start_fixup) [] Il.Dead;
+
+      (* zero marks the bottom of the frame chain. *)
+      Il.emit e (Il.Push (X86.imm (Asm.IMM 0L)));
+      Il.emit e (Il.umov (X86.rc X86.ebp) (X86.ro X86.esp));
+
+      (* 16-byte align stack for SSE. *)
+      Il.emit e (Il.binary Il.AND (X86.rc X86.esp) (X86.ro X86.esp)
+                   (X86.imm (Asm.IMM 0xfffffffffffffff0L)));
+
+      (* Store argv. *)
+      Abi.load_fixup_addr e edx nxargv_fixup Il.OpaqueTy;
+      Il.emit e (Il.lea (X86.rc X86.ecx)
+                   (Il.Cell (Il.Mem ((Il.RegIn (Il.Hreg X86.ebp,
+                                                Some (X86.word_off_n 2))),
+                                     Il.OpaqueTy))));
+      Il.emit e (Il.umov edx_pointee (X86.ro X86.ecx));
+      Il.emit e (Il.Push (X86.ro X86.ecx));
+
+      (* Store argc. *)
+      Abi.load_fixup_addr e edx nxargc_fixup Il.OpaqueTy;
+      Il.emit e (Il.umov (X86.rc X86.eax)
+                   (X86.c (X86.word_n (Il.Hreg X86.ebp) 1)));
+      Il.emit e (Il.umov edx_pointee (X86.ro X86.eax));
+      Il.emit e (Il.Push (X86.ro X86.eax));
+
+      (* Calculte and store envp. *)
+      Il.emit e (Il.binary Il.ADD
+                   (X86.rc X86.eax) (X86.ro X86.eax)
+                   (X86.imm (Asm.IMM 1L)));
+      Il.emit e (Il.binary Il.UMUL
+                   (X86.rc X86.eax) (X86.ro X86.eax)
+                   (X86.imm (Asm.IMM X86.word_sz)));
+      Il.emit e (Il.binary Il.ADD (X86.rc X86.eax)
+                   (X86.ro X86.eax) (X86.ro X86.ecx));
+      Abi.load_fixup_addr e edx environ_fixup Il.OpaqueTy;
+      Il.emit e (Il.umov edx_pointee (X86.ro X86.eax));
+
+      (* Push 16 bytes to preserve SSE alignment. *)
+      Abi.load_fixup_addr e edx sem.Semant.ctxt_crate_fixup Il.OpaqueTy;
+      Il.emit e (Il.Push (X86.ro X86.edx));
+      Abi.load_fixup_addr e edx main_fn_fixup Il.OpaqueTy;
+      Il.emit e (Il.Push (X86.ro X86.edx));
+      let fptr = Abi.load_fixup_codeptr e edx rust_start_fixup true true in
+        Il.emit e (Il.call (X86.rc X86.eax) fptr);
+        Il.emit e (Il.Pop (X86.rc X86.ecx));
+        Il.emit e (Il.Push (X86.ro X86.eax));
+        let fptr = Abi.load_fixup_codeptr e edx exit_fixup true true in
+          Il.emit e (Il.call (X86.rc X86.eax) fptr);
+          Il.emit e (Il.Pop (X86.rc X86.ecx));
+          Il.emit e (Il.Pop (X86.rc X86.ecx));
+          Il.emit e (Il.Pop (X86.rc X86.ecx));
+          Il.emit e (Il.Pop (X86.rc X86.ecx));
+
+          Il.emit e Il.Ret;
+  in
+
+  let text_section =
+    let start_code =
+      match (start_fixup, rust_start_fixup,
+             sem.Semant.ctxt_main_fn_fixup) with
+          (None, _, _)
+        | (_, None, _)
+        | (_, _, None) -> MARK
+        | (Some start_fixup,
+           Some rust_start_fixup,
+           Some main_fn_fixup) ->
+            let e = X86.new_emitter_without_vregs () in
+              objfile_start e start_fixup rust_start_fixup main_fn_fixup;
+              X86.frags_of_emitted_quads sess e
+    in
+      def_aligned text_sect_align text_section_fixup
+        (SEQ [|
+           start_code;
+           code
+         |])
+  in
+
+  let text_segment =
+      def_aligned seg_align text_segment_fixup
+        (SEQ [|
+           DEF (mh_execute_header_fixup, header_and_commands);
+           text_section;
+           align_both seg_align MARK;
+         |]);
+  in
+
+  let zero_segment = align_both seg_align
+    (SEQ [| MEMPOS 0L; DEF (zero_segment_fixup,
+                            SEQ [| MEMPOS 0x1000L; MARK |] ) |])
+  in
+
+  let data_segment = def_aligned seg_align data_segment_fixup
+    (SEQ [|
+       DEF(nxargc_fixup, WORD (TY_u32, IMM 0L));
+       DEF(nxargv_fixup, WORD (TY_u32, IMM 0L));
+       DEF(environ_fixup, WORD (TY_u32, IMM 0L));
+       DEF(progname_fixup, WORD (TY_u32, IMM 0L));
+       data_section;
+       const_section;
+       bss_section;
+       note_rust_section;
+       nl_symbol_ptr_section
+     |])
+  in
+
+  let dwarf_segment = def_aligned seg_align dwarf_segment_fixup
+    (SEQ [|
+       debug_info_section;
+       debug_abbrev_section;
+     |])
+  in
+
+  let linkedit_segment = def_aligned seg_align linkedit_segment_fixup
+    (SEQ [|
+       symtab;
+       strtab;
+       indirect_symtab;
+     |])
+  in
+
+  let segments =
+    SEQ [|
+      DEF (sem.Semant.ctxt_image_base_fixup, MARK);
+      zero_segment;
+      text_segment;
+      data_segment;
+      dwarf_segment;
+      linkedit_segment;
+    |]
+  in
+    write_out_frag sess true segments
+;;
+
+
+let sniff
+    (sess:Session.sess)
+    (filename:filename)
+    : asm_reader option =
+  try
+    let stat = Unix.stat filename in
+    if (stat.Unix.st_kind = Unix.S_REG) &&
+      (stat.Unix.st_size > 4)
+    then
+      let ar = new_asm_reader sess filename in
+      let _ = log sess "sniffing Mach-O file" in
+        if (ar.asm_get_u32()) = (Int64.to_int mh_magic)
+        then (ar.asm_seek 0; Some ar)
+        else None
+    else
+      None
+  with
+      _ -> None
+;;
+
+let get_sections
+    (sess:Session.sess)
+    (ar:asm_reader)
+    : (string,(int*int)) Hashtbl.t =
+  let sects = Hashtbl.create 0 in
+  let _ = log sess "reading sections" in
+  let magic = ar.asm_get_u32() in
+  let _ = assert (magic = (Int64.to_int mh_magic)) in
+  let _ = ar.asm_adv_u32() in (* cpu type *)
+  let _ = ar.asm_adv_u32() in (* cpu subtype *)
+  let _ = ar.asm_adv_u32() in (* file type *)
+  let n_load_cmds = ar.asm_get_u32() in
+  let _ = ar.asm_adv_u32() in
+  let _ = log sess "Mach-o file with %d load commands" n_load_cmds in
+  let _ = ar.asm_adv_u32() in (* flags *)
+  let lc_seg = Int64.to_int (load_command_code LC_SEGMENT) in
+    for i = 0 to n_load_cmds - 1 do
+      let load_cmd_code = ar.asm_get_u32() in
+      let load_cmd_size = ar.asm_get_u32() in
+      let _ = log sess "load command %d:" i in
+        if load_cmd_code != lc_seg
+        then ar.asm_adv (load_cmd_size - 8)
+        else
+          begin
+            let seg_name = ar.asm_get_zstr_padded 16 in
+            let _ = log sess "LC_SEGMENT %s" seg_name in
+            let _ = ar.asm_adv_u32() in (* seg mem pos *)
+            let _ = ar.asm_adv_u32() in (* seg mem sz *)
+            let _ = ar.asm_adv_u32() in (* seg file pos *)
+            let _ = ar.asm_adv_u32() in (* seg file sz *)
+            let _ = ar.asm_adv_u32() in (* maxprot *)
+            let _ = ar.asm_adv_u32() in (* initprot *)
+            let n_sects = ar.asm_get_u32() in
+            let _ = ar.asm_get_u32() in (* flags *)
+            let _ = log sess "%d sections" in
+              for j = 0 to n_sects - 1 do
+                let sect_name = ar.asm_get_zstr_padded 16 in
+                let _ = ar.asm_adv 16 in (* seg name *)
+                let _ = ar.asm_adv_u32() in (* sect mem pos *)
+                let m_sz = ar.asm_get_u32() in
+                let f_pos = ar.asm_get_u32() in
+                let _ = ar.asm_adv_u32() in (* sect align *)
+                let _ = ar.asm_adv_u32() in (* reloff *)
+                let _ = ar.asm_adv_u32() in (* nreloc *)
+                let _ = ar.asm_adv_u32() in (* flags *)
+                let _ = ar.asm_adv_u32() in (* reserved1 *)
+                let _ = ar.asm_adv_u32() in (* reserved2 *)
+                let _ =
+                  log sess
+                    "  section %d: 0x%x - 0x%x %s "
+                    j f_pos (f_pos + m_sz) sect_name
+                in
+                let len = String.length sect_name in
+                let sect_name =
+                  if (len > 2
+                      && sect_name.[0] = '_'
+                      && sect_name.[1] = '_')
+                  then "." ^ (String.sub sect_name 2 (len-2))
+                  else sect_name
+                in
+                  Hashtbl.add sects sect_name (f_pos, m_sz)
+              done
+          end
+    done;
+    sects
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)