Made x32 copy

runtime32/.gitignore

@@ -0,0 +1,2 @@
+*.a
+

runtime32/Makefile

@@ -0,0 +1,12 @@
+
+all: gc_runtime.o runtime.o
+	ar rc runtime.a gc_runtime.o runtime.o
+
+gc_runtime.o: gc_runtime.s
+	$(CC) -g -fstack-protector-all -m32 -c gc_runtime.s
+
+runtime.o: runtime.c runtime.h
+	$(CC) -g -fstack-protector-all -m32 -c runtime.c
+
+clean:
+	$(RM) *.a *.o *~

runtime32/Std.i

@@ -0,0 +1,59 @@
+F,assert;
+F,getEnv;
+F,system;
+V,sysargs;
+F,stringInt;
+F,makeArray;
+F,string;
+F,length;
+F,clone;
+F,hash;
+F,fst;
+F,snd;
+F,hd;
+F,tl;
+F,readLine;
+F,stringcat;
+F,matchSubString;
+F,substring;
+F,regexp;
+F,regexpMatch;
+F,sprintf;
+F,makeString;
+F,printf;
+F,fprintf;
+F,fopen;
+F,fclose;
+F,fread;
+F,fwrite;
+F,fexists;
+F,failure;
+F,read;
+F,write;
+F,compare;
+F,i__Infix_4343;
+F,s__Infix_58;
+F,s__Infix_3333;
+F,s__Infix_3838;
+F,s__Infix_6161;
+F,s__Infix_3361;
+F,s__Infix_6061;
+F,s__Infix_60;
+F,s__Infix_6261;
+F,s__Infix_62;
+F,s__Infix_43;
+F,s__Infix_45;
+F,s__Infix_42;
+F,s__Infix_47;
+F,s__Infix_37;
+L,"++",T,"+";
+F,enableGC;
+F,disableGC;
+F,random;
+F,time;
+F,kindOf;
+F,compareTags;
+F,flatCompare;
+F,tagHash;
+F,uppercase;
+F,lowercase;

runtime32/gc_runtime.s

@@ -0,0 +1,116 @@
+			.data
+printf_format:		.string	"Stack root: %lx\n"
+printf_format2:		.string	"BOT: %lx\n"
+printf_format3:		.string	"TOP: %lx\n"
+printf_format4:		.string	"EAX: %lx\n"
+printf_format5:		.string	"LOL\n"
+__gc_stack_bottom:	.long	0
+__gc_stack_top:	        .long	0
+
+			.globl	__pre_gc
+			.globl	__post_gc
+			.globl	__gc_init
+			.globl	__gc_root_scan_stack
+			.globl	__gc_stack_top
+			.globl	__gc_stack_bottom
+			.extern	init_pool
+			.extern	gc_test_and_copy_root
+			.text
+
+__gc_init:		movl	%ebp, __gc_stack_bottom
+			addl	$4, __gc_stack_bottom
+			call	__init
+			ret
+
+	// if __gc_stack_top is equal to 0
+	// then set __gc_stack_top to %ebp
+	// else return
+__pre_gc:
+			pushl	%eax
+			movl	__gc_stack_top, %eax
+			cmpl	$0, %eax
+			jne	__pre_gc_2
+			movl	%ebp, %eax
+			// addl	$8, %eax
+			movl	%eax, __gc_stack_top
+__pre_gc_2:
+			popl	%eax
+			ret
+
+	// if __gc_stack_top has been set by the caller
+	//   (i.e. it is equal to its %ebp)
+	// then set __gc_stack_top to 0
+	// else return
+__post_gc:
+			pushl	%eax
+			movl	__gc_stack_top, %eax
+			cmpl	%eax, %ebp
+			jnz	__post_gc2
+			movl	$0, __gc_stack_top
+__post_gc2:
+			popl	%eax
+			ret
+	
+	// Scan stack for roots
+	// strting from __gc_stack_top
+	// till __gc_stack_bottom
+__gc_root_scan_stack:
+			pushl	%ebp
+			movl	%esp, %ebp
+			pushl	%ebx
+			pushl	%edx
+			movl	__gc_stack_top, %eax
+			jmp 	next
+
+loop:
+			movl	(%eax), %ebx
+
+	// check that it is not a pointer to code section
+	// i.e. the following is not true:
+	// __executable_start <= (%eax) <= __etext
+check11:	
+			leal	__executable_start, %edx
+			cmpl	%ebx, %edx
+			jna	check12
+			jmp	check21
+
+check12:	
+			leal	__etext, %edx
+			cmpl	%ebx, %edx
+			jnb	next
+
+	// check that it is not a pointer into the program stack
+	// i.e. the following is not true:
+	// __gc_stack_bottom <= (%eax) <= __gc_stack_top
+check21:	
+			cmpl	%ebx, __gc_stack_top
+			jna	check22
+			jmp	loop2
+
+check22:
+			cmpl	%ebx, __gc_stack_bottom
+			jnb	next
+
+	// check if it a valid pointer
+	// i.e. the lastest bit is set to zero
+loop2:
+			andl	$0x00000001, %ebx
+			jnz     next
+gc_run_t:
+			pushl 	%eax
+  			pushl	%eax
+      			call	gc_test_and_copy_root
+        		addl	$4, %esp
+			popl	%eax
+
+next:
+			addl	$4, %eax
+			cmpl	%eax, __gc_stack_bottom
+			jne	loop
+returnn:
+			movl	$0, %eax
+			popl	%edx
+			popl	%ebx
+			movl	%ebp, %esp 
+			popl	%ebp
+			ret

runtime32/gr.dot

@@ -0,0 +1,2 @@
+  "runtime/" -> "negative_scenarios/";
+  "runtime/" -> "negative_scenarios/";

runtime32/runtime.h

@@ -0,0 +1,21 @@
+# ifndef __LAMA_RUNTIME__
+# define __LAMA_RUNTIME__
+
+# include <stdio.h>
+# include <stdio.h>
+# include <string.h>
+# include <stdarg.h>
+# include <stdlib.h>
+# include <sys/mman.h>
+# include <assert.h>
+# include <errno.h>
+# include <regex.h>
+# include <time.h>
+# include <limits.h>
+# include <ctype.h>
+
+# define WORD_SIZE (CHAR_BIT * sizeof(int))
+
+void failure (char *s, ...);
+
+# endif

src/X32.ml

@@ -0,0 +1,848 @@
+open GT
+open Language
+open SM
+   
+(* X86 codegeneration interface *)
+
+(* The registers: *)
+let regs = [|"%ebx"; "%ecx"; "%esi"; "%edi"; "%eax"; "%edx"; "%ebp"; "%esp"|]
+
+(* We can not freely operate with all register; only 3 by now *)
+let num_of_regs = Array.length regs - 5
+
+(* We need to know the word size to calculate offsets correctly *)
+let word_size = 4;;
+
+(* We need to distinguish the following operand types: *)
+@type opnd =
+| R  of int        (* hard register                    *)
+| S  of int        (* a position on the hardware stack *)
+| C                (* a saved closure                  *)
+| M  of string     (* a named memory location          *)
+| L  of int        (* an immediate operand             *)
+| I  of int * opnd (* an indirect operand with offset  *)
+with show
+
+let show_opnd = show(opnd)
+
+(* For convenience we define the following synonyms for the registers: *)
+let ebx = R 0
+let ecx = R 1
+let esi = R 2
+let edi = R 3
+let eax = R 4
+let edx = R 5
+let ebp = R 6
+let esp = R 7
+
+(* Now x86 instruction (we do not need all of them): *)
+type instr =
+(* copies a value from the first to the second operand   *) | Mov   of opnd * opnd
+(* loads an address of the first operand into the second *) | Lea   of opnd * opnd
+(* makes a binary operation; note, the first operand     *) | Binop of string * opnd * opnd
+(* designates x86 operator, not the source language one  *)
+(* x86 integer division, see instruction set reference   *) | IDiv  of opnd
+(* see instruction set reference                         *) | Cltd
+(* sets a value from flags; the first operand is the     *) | Set   of string * string
+(* suffix, which determines the value being set, the     *)
+(* the second --- (sub)register name                     *)
+(* pushes the operand on the hardware stack              *) | Push  of opnd
+(* pops from the hardware stack to the operand           *) | Pop   of opnd
+(* call a function by a name                             *) | Call  of string
+(* call a function by indirect address                   *) | CallI of opnd
+(* returns from a function                               *) | Ret
+(* a label in the code                                   *) | Label of string
+(* a conditional jump                                    *) | CJmp  of string * string
+(* a non-conditional jump                                *) | Jmp   of string
+(* directive                                             *) | Meta  of string
+
+(* arithmetic correction: decrement                      *) | Dec   of opnd
+(* arithmetic correction: or 0x0001                      *) | Or1   of opnd
+(* arithmetic correction: shl 1                          *) | Sal1  of opnd
+(* arithmetic correction: shr 1                          *) | Sar1  of opnd
+                                                            | Repmovsl
+(* Instruction printer *)
+let stack_offset i =
+  if i >= 0
+  then (i+1) * word_size
+  else 8 + (-i-1) * word_size
+  
+let show instr =
+  let rec opnd = function
+  | R i      -> regs.(i)
+  | C        -> "4(%ebp)"              
+  | S i      -> if i >= 0
+                then Printf.sprintf "-%d(%%ebp)" (stack_offset i)
+                else Printf.sprintf "%d(%%ebp)"  (stack_offset i)
+  | M x      -> x
+  | L i      -> Printf.sprintf "$%d" i
+  | I (0, x) -> Printf.sprintf "(%s)" (opnd x)
+  | I (n, x) -> Printf.sprintf "%d(%s)" n (opnd x)
+  in
+  let binop = function
+  | "+"    -> "addl"
+  | "-"    -> "subl"
+  | "*"    -> "imull"
+  | "&&"   -> "andl"
+  | "!!"   -> "orl"
+  | "^"    -> "xorl"
+  | "cmp"  -> "cmpl"
+  | "test" -> "test"
+  | _      -> failwith "unknown binary operator"
+  in
+  match instr with
+  | Cltd               -> "\tcltd"
+  | Set   (suf, s)     -> Printf.sprintf "\tset%s\t%s"     suf s
+  | IDiv   s1          -> Printf.sprintf "\tidivl\t%s"     (opnd s1)
+  | Binop (op, s1, s2) -> Printf.sprintf "\t%s\t%s,\t%s"   (binop op) (opnd s1) (opnd s2)
+  | Mov   (s1, s2)     -> Printf.sprintf "\tmovl\t%s,\t%s" (opnd s1) (opnd s2)
+  | Lea   (x,  y)      -> Printf.sprintf "\tleal\t%s,\t%s" (opnd x) (opnd y)
+  | Push   s           -> Printf.sprintf "\tpushl\t%s"     (opnd s)
+  | Pop    s           -> Printf.sprintf "\tpopl\t%s"      (opnd s)
+  | Ret                -> "\tret"
+  | Call   p           -> Printf.sprintf "\tcall\t%s" p
+  | CallI  o           -> Printf.sprintf "\tcall\t*(%s)" (opnd o)
+  | Label  l           -> Printf.sprintf "%s:\n" l
+  | Jmp    l           -> Printf.sprintf "\tjmp\t%s" l
+  | CJmp  (s , l)      -> Printf.sprintf "\tj%s\t%s" s l
+  | Meta   s           -> Printf.sprintf "%s\n" s
+  | Dec    s           -> Printf.sprintf "\tdecl\t%s" (opnd s)
+  | Or1    s           -> Printf.sprintf "\torl\t$0x0001,\t%s" (opnd s)
+  | Sal1   s           -> Printf.sprintf "\tsall\t%s" (opnd s)
+  | Sar1   s           -> Printf.sprintf "\tsarl\t%s" (opnd s)
+  | Repmovsl           -> Printf.sprintf "\trep movsl\t"
+
+(* Opening stack machine to use instructions without fully qualified names *)
+open SM
+
+(* Symbolic stack machine evaluator
+
+     compile : env -> prg -> env * instr list
+
+   Take an environment, a stack machine program, and returns a pair --- the updated environment and the list
+   of x86 instructions
+*)
+let compile cmd env imports code =
+  (* SM.print_prg code; *)
+  flush stdout;
+  let suffix = function
+  | "<"  -> "l"
+  | "<=" -> "le"
+  | "==" -> "e"
+  | "!=" -> "ne"
+  | ">=" -> "ge"
+  | ">"  -> "g"
+  | _    -> failwith "unknown operator"
+  in
+  let box n = (n lsl 1) lor 1 in 
+  let rec compile' env scode =
+    let on_stack = function S _ -> true | _ -> false in
+    let mov x s = if on_stack x && on_stack s then [Mov (x, eax); Mov (eax, s)] else [Mov (x, s)]  in
+    let callc env n tail =
+      let tail = tail && env#nargs = n in 
+      if tail
+      then (
+        let rec push_args env acc = function
+        | 0 -> env, acc
+        | n -> let x, env = env#pop in
+               if x = env#loc (Value.Arg (n-1))
+               then push_args env acc (n-1)
+               else push_args env ((mov x (env#loc (Value.Arg (n-1)))) @ acc) (n-1)
+        in
+        let env    , pushs = push_args env [] n in
+        let closure, env   = env#pop in
+        let y      , env   = env#allocate in
+        env, pushs @ [Mov (closure, edx);
+                      Mov (I(0, edx), eax);
+                      Mov (ebp, esp);
+                      Pop (ebp)] @
+                      (if env#has_closure then [Pop ebx] else []) @
+                      [Jmp "*%eax"] (* UGLY!!! *)
+      )
+      else (
+        let pushr, popr =
+          List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
+        in
+        let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in
+        let env, code =
+          let rec push_args env acc = function
+          | 0 -> env, acc
+          | n -> let x, env = env#pop in
+                 push_args env ((Push x)::acc) (n-1)
+          in
+          let env, pushs   = push_args env [] n in
+          let pushs        = List.rev pushs     in
+          let closure, env = env#pop            in
+          let call_closure =
+            if on_stack closure
+            then [Mov (closure, edx); Mov (edx, eax); CallI eax]
+            else [Mov (closure, edx); CallI closure]
+          in
+          env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) 
+        in
+        let y, env = env#allocate in env, code @ [Mov (eax, y)]
+      )
+    in
+    let call env f n tail =
+      let tail = tail && env#nargs = n && f.[0] <> '.' in 
+      let f =
+        match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f
+      in
+      if tail
+      then (
+        let rec push_args env acc = function
+        | 0 -> env, acc
+        | n -> let x, env = env#pop in
+               if x = env#loc (Value.Arg (n-1))
+               then push_args env acc (n-1)
+               else push_args env ((mov x (env#loc (Value.Arg (n-1)))) @ acc) (n-1)
+        in
+        let env, pushs = push_args env [] n in
+        let y, env = env#allocate in
+        env, pushs @ [Mov (ebp, esp); Pop (ebp)] @ (if env#has_closure then [Pop ebx] else []) @ [Jmp f]
+      )
+      else (
+        let pushr, popr =
+          List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
+        in      
+        let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in
+        let env, code =
+          let rec push_args env acc = function
+            | 0 -> env, acc
+            | n -> let x, env = env#pop in
+                   push_args env ((Push x)::acc) (n-1)
+          in
+          let env, pushs = push_args env [] n in
+          let pushs      =
+            match f with
+            | "Barray" -> List.rev @@ (Push (L (box n))) :: pushs
+            | "Bsexp"  -> List.rev @@ (Push (L (box n))) :: pushs
+            | "Bsta"   -> pushs
+            | _        -> List.rev pushs
+          in
+          env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) 
+        in
+        let y, env = env#allocate in env, code @ [Mov (eax, y)]
+      )
+    in
+    match scode with
+    | [] -> env, []
+    | instr :: scode' ->
+        let stack = "" (* env#show_stack*) in
+        (* Printf.printf "insn=%s, stack=%s\n%!" (GT.show(insn) instr) (env#show_stack);   *)
+        let env', code' =
+          if env#is_barrier
+          then match instr with
+               | LABEL  s -> if env#has_stack s then (env#drop_barrier)#retrieve_stack s, [Label s] else env#drop_stack, []
+               | FLABEL s -> env#drop_barrier, [Label s]
+               | SLABEL s -> env, [Label s]
+               | _        -> env, []
+          else
+          match instr with
+          | PUBLIC name -> env#register_public name, []
+          | EXTERN name -> env#register_extern name, []
+          | IMPORT name -> env, []
+                         
+          | CLOSURE (name, closure) ->
+             let pushr, popr =
+               List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0)
+             in
+             let closure_len  = List.length closure in 
+             let push_closure =
+               List.map (fun d -> Push (env#loc d)) @@ List.rev closure
+             in
+             let s, env = env#allocate in             
+             (env,
+              pushr @
+              push_closure @
+              [Push (M ("$" ^ name));
+              Push (L (box closure_len));
+              Call "Bclosure";
+              Binop ("+", L (word_size * (closure_len + 2)), esp); 
+              Mov (eax, s)] @
+              List.rev popr @ env#reload_closure)
+             
+  	  | CONST n ->
+             let s, env' = env#allocate in
+	     (env', [Mov (L (box n), s)])
+
+          | STRING s ->
+             let s, env = env#string s in
+             let l, env = env#allocate in
+             let env, call = call env ".string" 1 false in
+             (env, Mov (M ("$" ^ s), l) :: call)
+
+          | LDA x ->
+             let s,  env' = (env #variable x)#allocate in
+             let s', env''= env'#allocate in
+             env'',
+             [Lea (env'#loc x, eax); Mov (eax, s); Mov (eax, s')]	     
+
+	  | LD x ->
+             let s, env' = (env#variable x)#allocate in
+             env',
+	     (match s with
+	      | S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)]
+	      | _         -> [Mov (env'#loc x, s)]
+	     )
+
+          | ST x ->
+	     let env' = env#variable x in
+             let s    = env'#peek      in
+             env',
+             (match s with
+              | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)]
+              | _         -> [Mov (s, env'#loc x)]
+	     )
+
+          | STA ->
+             call env ".sta" 3 false
+
+	  | STI ->
+             let v, x, env' = env#pop2 in
+             env'#push x,
+             (match x with
+              | S _ | M _ -> [Mov (v, edx); Mov (x, eax); Mov (edx, I (0, eax)); Mov (edx, x)] @ env#reload_closure
+              | _         -> [Mov (v, eax); Mov (eax, I (0, x)); Mov (eax, x)]
+             )
+
+          | BINOP op ->
+	     let x, y, env' = env#pop2 in
+             env'#push y,
+             (match op with
+	      | "/" ->
+                 [Mov (y, eax);
+                  Sar1 eax;
+                  Cltd;
+                  (* x := x >> 1 ?? *)
+                  Sar1 x; (*!!!*)
+                  IDiv x;
+                  Sal1 eax;
+                  Or1 eax;
+                  Mov (eax, y)
+                 ]
+              | "%" ->
+                 [Mov (y, eax);
+                  Sar1 eax;
+                  Cltd;
+                  (* x := x >> 1 ?? *)
+                  Sar1 x; (*!!!*)
+                  IDiv x;
+                  Sal1 edx;
+                  Or1  edx;
+                  Mov (edx, y)
+                 ] @ env#reload_closure
+              | "<" | "<=" | "==" | "!=" | ">=" | ">" ->
+                 (match x with
+                  | M _ | S _ ->
+                     [Binop ("^", eax, eax);
+                      Mov   (x, edx);
+                      Binop ("cmp", edx, y);
+                      Set   (suffix op, "%al");
+                      Sal1   eax;
+                      Or1    eax;
+                      Mov   (eax, y)
+                     ] @ env#reload_closure
+                  | _ ->
+                     [Binop ("^"  , eax, eax);
+                      Binop ("cmp", x, y);
+                      Set   (suffix op, "%al");
+                      Sal1   eax;
+                      Or1    eax;
+                      Mov   (eax, y)
+                     ]
+                 )
+              | "*" ->
+                 if on_stack y
+                 then [Dec y; Mov (x, eax); Sar1 eax; Binop (op, y, eax); Or1 eax; Mov (eax, y)]
+                 else [Dec y; Mov (x, eax); Sar1 eax; Binop (op, eax, y); Or1 y]
+	      | "&&" ->
+		 [Dec    x; (*!!!*)
+                  Mov   (x, eax);
+		  Binop (op, x, eax);
+		  Mov   (L 0, eax);
+		  Set   ("ne", "%al");
+
+                  Dec    y; (*!!!*)
+		  Mov   (y, edx);
+		  Binop (op, y, edx);
+		  Mov   (L 0, edx);
+		  Set   ("ne", "%dl");
+
+                  Binop (op, edx, eax);
+		  Set   ("ne", "%al");
+                  Sal1  eax;
+                  Or1   eax;
+		  Mov   (eax, y)
+                 ] @ env#reload_closure
+	      | "!!" ->
+		 [Mov   (y, eax);
+                  Sar1  eax;
+                  Sar1  x; (*!!!*)
+		  Binop (op, x, eax);
+                  Mov   (L 0, eax);
+		  Set   ("ne", "%al");
+                  Sal1  eax;
+                  Or1   eax;
+		  Mov   (eax, y)
+                 ]
+	      | "+" ->
+                 if on_stack x && on_stack y
+                 then [Mov   (x, eax); Dec eax; Binop ("+", eax, y)]
+                 else [Binop (op, x, y); Dec y]
+              | "-" ->
+                 if on_stack x && on_stack y
+                 then [Mov   (x, eax); Binop (op, eax, y); Or1 y]
+                 else [Binop (op, x, y); Or1 y]
+             )
+             
+          | LABEL  s 
+          | FLABEL s
+          | SLABEL s    -> env, [Label s]
+
+	  | JMP   l     -> (env#set_stack l)#set_barrier, [Jmp l]
+
+          | CJMP (s, l) ->
+              let x, env = env#pop in
+              env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp  (s, l)]
+
+          | BEGIN (f, nargs, nlocals, closure, args, scopes) ->             
+             let rec stabs_scope scope =
+               let names =
+                 List.map
+                   (fun (name, index) ->
+                     Meta (Printf.sprintf "\t.stabs \"%s:1\",128,0,0,-%d" name (stack_offset index))
+                   )
+                   scope.names
+               in
+               names @
+               (if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 192,0,0,%s-%s" scope.blab f)]) @
+               (List.flatten @@ List.map stabs_scope scope.subs) @
+               (if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 224,0,0,%s-%s" scope.elab f)])
+             in    
+             let name =
+               if f.[0] = 'L' then String.sub f 1 (String.length f - 1) else f
+             in
+             env#assert_empty_stack;
+             let has_closure = closure <> [] in
+             let env         = env#enter f nargs nlocals has_closure in
+             env, [Meta (Printf.sprintf "\t.type %s, @function" name)] @
+                  (if f = "main"
+                   then []
+                   else 
+                     [Meta (Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" name f)] @
+                     (List.mapi (fun i a -> Meta (Printf.sprintf "\t.stabs \"%s:p1\",160,0,0,%d" a ((i*4) + 8))) args)  @
+                     (List.flatten @@ List.map stabs_scope scopes)                         
+                  )
+                  @
+                  [Meta "\t.cfi_startproc"] @
+                  (if has_closure then [Push edx] else []) @
+                  (if f = cmd#topname
+                   then
+                     [Mov   (M "_init", eax);
+                      Binop ("test", eax, eax);
+                      CJmp  ("z", "_continue");
+                      Ret;
+                      Label "_continue";
+                      Mov (L 1, M "_init");
+                     ]
+                   else []
+                  ) @                  
+                  [Push ebp;
+                   Meta ("\t.cfi_def_cfa_offset\t" ^ if has_closure then "12" else "8");
+                   Meta ("\t.cfi_offset 5, -" ^ if has_closure then "12" else "8");
+                   Mov (esp, ebp);
+                   Meta "\t.cfi_def_cfa_register\t5";
+                   Binop ("-", M ("$" ^ env#lsize), esp);
+                   Mov (esp, edi);
+	           Mov (M "$filler", esi);
+	           Mov (M ("$" ^ (env#allocated_size)), ecx);
+	           Repmovsl
+                  ] @
+                  (if f = "main"
+                   then [Call "__gc_init"; Push (I (12, ebp)); Push (I (8, ebp)); Call "set_args"; Binop ("+", L 8, esp)]
+                   else []
+                  ) @
+                  (if f = cmd#topname
+                   then List.map (fun i -> Call ("init" ^ i)) (List.filter (fun i -> i <> "Std") imports)
+                   else []
+                  )    
+
+          | END ->
+             let x, env = env#pop in
+             env#assert_empty_stack;
+             let name = env#fname in
+             env#leave, [
+                 Mov (x, eax); (*!!*)
+                 Label env#epilogue;
+                 Mov (ebp, esp);
+                 Pop ebp;
+               ] @
+               env#rest_closure @
+               (if name = "main" then [Binop ("^", eax, eax)] else []) @
+               [Meta "\t.cfi_restore\t5";
+	        Meta "\t.cfi_def_cfa\t4, 4";
+                Ret;
+                Meta "\t.cfi_endproc";
+                Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size));
+                Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated);
+                Meta (Printf.sprintf "\t.size %s, .-%s" name name);
+               ]
+
+          | RET ->
+             let x = env#peek in
+             env, [Mov (x, eax); Jmp env#epilogue]
+
+          | ELEM              -> call env ".elem" 2 false
+                               
+          | CALL (f, n, tail) -> call env f n tail
+                         
+          | CALLC (n, tail) -> callc env n tail
+              
+          | SEXP (t, n) ->
+             let s, env = env#allocate in
+             let env, code = call env ".sexp" (n+1) false in
+             env, [Mov (L (box (env#hash t)), s)] @ code
+
+          | DROP ->
+             snd env#pop, []
+
+          | DUP  ->
+             let x      = env#peek in
+             let s, env = env#allocate in
+             env, mov x s
+
+          | SWAP ->
+             let x, y = env#peek2 in
+             env, [Push x; Push y; Pop x; Pop y]
+
+          | TAG (t, n) ->
+             let s1, env = env#allocate in
+             let s2, env = env#allocate in
+             let env, code = call env ".tag" 3 false in
+             env, [Mov (L (box (env#hash t)), s1); Mov (L (box n), s2)] @ code
+
+          | ARRAY n ->
+             let s, env    = env#allocate in
+             let env, code = call env ".array_patt" 2 false in
+             env, [Mov (L (box n), s)] @ code
+
+          | PATT StrCmp -> call env ".string_patt" 2 false
+
+          | PATT patt ->
+             call env 
+               (match patt with
+                | Boxed   -> ".boxed_patt"
+                | UnBoxed -> ".unboxed_patt"
+                | Array   -> ".array_tag_patt"
+                | String  -> ".string_tag_patt"
+                | Sexp    -> ".sexp_tag_patt"
+                | Closure -> ".closure_tag_patt"
+               ) 1 false
+          | LINE (line) ->
+             env#gen_line line
+             
+          | FAIL ((line, col), value) ->                       
+             let v, env = if value then env#peek, env else env#pop in
+             let s, env = env#string cmd#get_infile in
+             env, [Push (L (box col)); Push (L (box line)); Push (M ("$" ^ s)); Push v; Call "Bmatch_failure"; Binop  ("+", L (4 * word_size), esp)]
+             
+          | i ->
+             invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i))
+        in
+        let env'', code'' = compile' env' scode' in
+	env'', [Meta (Printf.sprintf "# %s / % s" (GT.show(SM.insn) instr) stack)] @ code' @ code''
+  in
+  compile' env code
+  
+(* A set of strings *)
+module S = Set.Make (String)
+
+(* A map indexed by strings *)
+module M = Map.Make (String)
+
+(* Environment implementation *)
+class env prg =
+  let chars          = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'" in
+  let make_assoc l i = List.combine l (List.init (List.length l) (fun x -> x + i)) in
+  let rec assoc  x   = function [] -> raise Not_found | l :: ls -> try List.assoc x l with Not_found -> assoc x ls in
+  object (self)
+    inherit SM.indexer prg
+    val globals         = S.empty (* a set of global variables         *)
+    val stringm         = M.empty (* a string map                      *)
+    val scount          = 0       (* string count                      *)
+    val stack_slots     = 0       (* maximal number of stack positions *)
+                        
+    val static_size     = 0       (* static data size                  *)
+    val stack           = []      (* symbolic stack                    *)
+    val nargs           = 0       (* number of function arguments      *)
+    val locals          = []      (* function local variables          *)
+    val fname           = ""      (* function name                     *)
+    val stackmap        = M.empty (* labels to stack map               *)
+    val barrier         = false   (* barrier condition                 *)
+    val max_locals_size = 0
+    val has_closure     = false
+    val publics         = S.empty
+    val externs         = S.empty
+    val nlabels         = 0
+    val first_line      = true
+                        
+    method publics = S.elements publics
+                   
+    method register_public name = {< publics = S.add name publics >}
+    method register_extern name = {< externs = S.add name externs >}
+                                
+    method max_locals_size = max_locals_size
+                           
+    method has_closure = has_closure
+                       
+    method save_closure =
+      if has_closure then [Push edx] else []
+
+    method rest_closure =
+      if has_closure then [Pop edx] else []
+
+    method reload_closure =
+      if has_closure then [Mov (C (*S 0*), edx)] else []
+      
+    method fname = fname
+                 
+    method leave =
+      if stack_slots > max_locals_size
+      then {< max_locals_size = stack_slots >}
+      else self
+
+    method show_stack =
+      GT.show(list) (GT.show(opnd)) stack
+
+    method print_locals =
+      Printf.printf "LOCALS: size = %d\n" static_size;
+      List.iter
+        (fun l ->
+          Printf.printf "(";
+          List.iter (fun (a, i) -> Printf.printf "%s=%d " a i) l;
+          Printf.printf ")\n"
+        ) locals;
+      Printf.printf "END LOCALS\n"
+
+    (* Assert empty stack *)
+    method assert_empty_stack = assert (stack = [])
+
+    (* check barrier condition *)
+    method is_barrier = barrier
+
+    (* set barrier *)
+    method set_barrier = {< barrier = true >}
+
+    (* drop barrier *)
+    method drop_barrier = {< barrier = false >}
+
+    (* drop stack *)
+    method drop_stack = {< stack = [] >}
+
+    (* associates a stack to a label *)
+    method set_stack l = (*Printf.printf "Setting stack for %s\n" l;*)
+      {< stackmap = M.add l stack stackmap >}
+
+    (* retrieves a stack for a label *)
+    method retrieve_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*)
+      try {< stack = M.find l stackmap >} with Not_found -> self
+
+    (* checks if there is a stack for a label *)
+    method has_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*)
+      M.mem l stackmap
+
+    (* gets a name for a global variable *)
+    method loc x =
+      match x with
+      | Value.Global name -> M ("global_" ^ name)
+      | Value.Fun    name -> M ("$" ^ name)
+      | Value.Local  i    -> S i
+      | Value.Arg    i    -> S (- (i + if has_closure then 2 else 1))
+      | Value.Access i    -> I (word_size * (i+1), edx)
+         
+    (* allocates a fresh position on a symbolic stack *)
+    method allocate =
+      let x, n =
+        let rec allocate' = function
+        | []                            -> ebx          , 0
+        | (S n)::_                      -> S (n+1)      , n+2
+        | (R n)::_ when n < num_of_regs -> R (n+1)      , stack_slots
+        | _                             -> S static_size, static_size+1
+        in
+        allocate' stack
+      in
+      x, {< stack_slots = max n stack_slots; stack = x::stack >}
+
+    (* pushes an operand to the symbolic stack *)
+    method push y = {< stack = y::stack >}
+
+    (* pops one operand from the symbolic stack *)
+    method pop = let x::stack' = stack in x, {< stack = stack' >}
+
+    (* pops two operands from the symbolic stack *)
+    method pop2 = let x::y::stack' = stack in x, y, {< stack = stack' >}
+
+    (* peeks the top of the stack (the stack does not change) *)
+    method peek = List.hd stack
+
+    (* peeks two topmost values from the stack (the stack itself does not change) *)
+    method peek2 = let x::y::_ = stack in x, y
+
+    (* tag hash: gets a hash for a string tag *)
+    method hash tag =
+      let h = Pervasives.ref 0 in
+      for i = 0 to min (String.length tag - 1) 4 do
+        h := (!h lsl 6) lor (String.index chars tag.[i])
+      done;
+      !h
+
+    (* registers a variable in the environment *)
+    method variable x =
+      match x with
+      | Value.Global name -> {< globals = S.add ("global_" ^ name) globals >}
+      | _                 -> self
+
+    (* registers a string constant *)
+    method string x =
+      let escape x =
+        let n   = String.length x     in
+        let buf = Buffer.create (n*2) in
+        let rec iterate i =
+          if i < n
+          then (
+            (match x.[i] with
+            | '"'  -> Buffer.add_string buf "\\\""
+            | '\n' -> Buffer.add_string buf "\n"
+            | '\t' -> Buffer.add_string buf "\t"
+            | c    -> Buffer.add_char buf c
+            );
+            iterate (i+1)
+          )
+        in
+        iterate 0;
+        Buffer.contents buf
+      in
+      let x = escape x in
+      try M.find x stringm, self
+      with Not_found ->
+        let y = Printf.sprintf "string_%d" scount in
+        let m = M.add x y stringm in
+        y, {< scount = scount + 1; stringm = m>}
+
+    (* gets number of arguments in the current function *)
+    method nargs = nargs
+                 
+    (* gets all global variables *)
+    method globals = S.elements (S.diff globals externs)
+
+    (* gets all string definitions *)
+    method strings = M.bindings stringm
+
+    (* gets a number of stack positions allocated *)
+    method allocated = stack_slots
+                     
+    method allocated_size = Printf.sprintf "LS%s_SIZE" fname
+                     
+    (* enters a function *)
+    method enter f nargs nlocals has_closure =
+      {< nargs = nargs; static_size = nlocals; stack_slots = nlocals; stack = []; fname = f; has_closure = has_closure; first_line = true >}
+
+    (* returns a label for the epilogue *)
+    method epilogue = Printf.sprintf "L%s_epilogue" fname
+
+    (* returns a name for local size meta-symbol *)
+    method lsize = Printf.sprintf "L%s_SIZE" fname
+                    
+    (* returns a list of live registers *)
+    method live_registers depth =
+      let rec inner d acc = function
+      | []             -> acc
+      | (R _ as r)::tl -> inner (d+1) (if d >= depth then (r::acc) else acc) tl
+      | _::tl          -> inner (d+1) acc tl
+      in
+      inner 0 [] stack
+
+    (* generate a line number information for current function *)
+    method gen_line line =
+      let lab = Printf.sprintf ".L%d" nlabels in
+      {< nlabels = nlabels + 1; first_line = false >},
+      if fname = "main"
+      then
+         [Meta (Printf.sprintf "\t.stabn 68,0,%d,%s" line lab); Label lab]
+      else
+        (if first_line then [Meta (Printf.sprintf "\t.stabn 68,0,%d,0" line)] else []) @  
+        [Meta (Printf.sprintf "\t.stabn 68,0,%d,%s-%s" line lab fname); Label lab]
+      
+  end
+
+(* Generates an assembler text for a program: first compiles the program into
+   the stack code, then generates x86 assember code, then prints the assembler file
+*)
+let genasm cmd prog =
+  let sm        = SM.compile cmd prog in
+  let env, code = compile cmd (new env sm) (fst (fst prog)) sm in
+  let globals =
+    List.map (fun s -> Meta (Printf.sprintf "\t.globl\t%s" s)) env#publics
+  in
+  let data = [Meta "\t.data"] @
+             (List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings) @
+             [Meta "_init:\t.int 0";
+              Meta "\t.section custom_data,\"aw\",@progbits";
+              Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size)] @
+              (List.concat @@
+                 List.map
+                   (fun s -> [Meta (Printf.sprintf "\t.stabs \"%s:S1\",40,0,0,%s" (String.sub s (String.length "global_") (String.length s - String.length "global_")) s);
+                              Meta (Printf.sprintf "%s:\t.int\t1" s)])
+                   env#globals
+              )
+  in
+  let asm = Buffer.create 1024 in
+  List.iter
+    (fun i -> Buffer.add_string asm (Printf.sprintf "%s\n" @@ show i))
+    ([Meta (Printf.sprintf "\t.file \"%s\"" cmd#get_absolute_infile);
+      Meta (Printf.sprintf "\t.stabs \"%s\",100,0,0,.Ltext" cmd#get_absolute_infile)] @
+      globals @
+      data @
+      [Meta "\t.text"; Label ".Ltext"; Meta "\t.stabs \"data:t1=r1;0;4294967295;\",128,0,0,0"] @          
+      code);
+  Buffer.contents asm
+
+let get_std_path () =
+  match Sys.getenv_opt "LAMA" with
+  | Some s -> s
+  | None   -> Stdpath.path
+                                      
+(* Builds a program: generates the assembler file and compiles it with the gcc toolchain *)
+let build cmd prog =
+  let find_objects imports paths =
+    let module S = Set.Make (String) in
+    let rec iterate acc s = function
+    | []              -> acc
+    | import::imports -> 
+       if S.mem import s
+       then iterate acc s imports
+       else
+         let path, intfs = Interface.find import paths in         
+         iterate
+           ((Filename.concat path (import ^ ".o")) :: acc)
+           (S.add import s)
+           ((List.map (function `Import name -> name | _ -> invalid_arg "must not happen") @@
+             List.filter (function `Import _ -> true | _ -> false) intfs) @
+             imports)
+    in
+    iterate [] (S.add "Std" S.empty) imports
+  in
+  cmd#dump_file "s" (genasm cmd prog);
+  cmd#dump_file "i" (Interface.gen prog);
+  let inc  = get_std_path () in
+  match cmd#get_mode with
+  | `Default ->
+     let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in
+     let buf  = Buffer.create 255 in
+     List.iter (fun o -> Buffer.add_string buf o; Buffer.add_string buf " ") objs;
+     let gcc_cmdline = Printf.sprintf "gcc %s -m32 %s %s.s %s %s/runtime.a" cmd#get_debug cmd#get_output_option cmd#basename (Buffer.contents buf) inc in
+     Sys.command gcc_cmdline
+  | `Compile ->
+     Sys.command (Printf.sprintf "gcc %s -m32 -c %s.s" cmd#get_debug cmd#basename)
+  | _ -> invalid_arg "must not happen"