Cousineau G., Curien P.-L., Mauny M. The categorical abstract machine. — LNCS, 201, Functional programming languages computer architecture.-- 1985, pp.~50-64.

CAM.ml

type expr =
  | MLplus | MLequal | MLfst | MLsnd
  | MLint of int
  | MLbool of bool
  | MLvar of string
  | MLcond of expr * expr * expr
  | MLpair of expr * expr
  | MLin of dec * expr
  | MLabstr of pat * expr
  | MLapp of expr * expr
 and dec =
   | MLlet of pat * expr
   | MLletrec of pat * expr
 and pat =
   | Nullpat
   | Varpat of string
   | Pairpat of pat * pat;;

type instruction =
  | Plus | Eq
  | Quote of value
  | Fst | Snd | Cons | Wind
  | Push | Swap | Return | App
  | Cur of code
  | Branch of code * code
 and value =
   | Nullvalue
   | Int of int
   | Bool of bool
   | Pair of value * value
   | Closure of code * value
 and code = instruction list;;

type stackelem = Val of value
               | Code of code;;
type stack = stackelem list;;
type config = value ref * code * stack;;

let rec exec : config -> config = fun w ->
  match w with
  | ({ contents = Pair(x,y) },(Fst::c),d) -> exec(ref x,c,d)
  | ({ contents = Pair(x,y) },(Snd::c),d) -> exec(ref y,c,d)
  | (x,(Cons::c),(Val y)::d) -> exec(ref (Pair(y,!x)),c,d)
  | (x,(Wind::c),((Val (Pair(y,z) as u))::d)) -> ref z := !x; exec(ref u,c,d)
  | ({ contents = x },(Push::c),d) -> exec(ref x,c,(Val x)::d)
  | ({ contents = x },(Swap::c),(Val y::d)) -> exec(ref y,c,(Val x)::d)
  | (t,((Quote v)::c),d) -> exec(ref v,c,d)
  | ({ contents = Pair(Closure(x,y),z) },(App::c),d) -> exec(ref (Pair(y,z)),x,(Code c)::d)
  | ({ contents = Bool(b) },((Branch(c1,c2))::c),((Val x)::d)) -> exec(ref x, (if b then c1 else c2), (Code c)::d)
  | ({ contents = Pair(Int m,Int n) },(Plus::c),d) -> exec(ref (Int(m+n)),c,d)
  | ({ contents = Pair(Int m,Int n) },(Eq::c),d) -> exec(ref (Bool(m=n)),c,d)
  | ({ contents = x },((Cur c1)::c),d) -> exec(ref (Closure(c1,x)),c,d)
  | ({ contents = x },(Return::c),((Code c')::d)) -> exec(ref x,c',d)
  | config -> config;;

let exec_code : code -> config = fun cs -> exec(ref Nullvalue,cs,[]);;

let rec access : string -> pat -> code = fun id w ->
  match w with
  | Nullpat -> failwith "nullpat"
  | (Varpat x) -> if x = id then [] else failwith "x /= id"
  | (Pairpat (x1,x2)) -> try (Snd::(access id x2)) with Failure(_) -> (Fst :: (access id x1));;

let rec compile : pat -> expr -> code = fun pat w ->
  match w with
  | (MLint n) -> [Quote (Int n)]
  | (MLbool b) -> [Quote (Bool b)]
  | (MLvar v) -> access v pat
  | (MLcond(e1,e2,e3)) ->
     [Push] @ (compile pat e1) @
       [Branch((compile pat e2) @ [Return], (compile pat e3) @ [Return])]
  | (MLpair(e1,e2)) ->
     [Push] @ (compile pat e1) @ [Swap] @ (compile pat e2) @ [Cons]
  | (MLin(MLlet(p,e1),e2)) -> let pat' = Pairpat(pat,p) in
     [Push] @ (compile pat e1) @ [Cons] @ (compile pat' e2)
  | (MLin(MLletrec(p,e1),e2)) -> let pat' = Pairpat(pat,p) in
     [Push; Quote Nullvalue; Cons; Push] @ (compile pat' e1) @
       [Swap; Wind] @ (compile pat' e2)
  | (MLabstr(p,e)) -> let pat' = Pairpat(pat,p) in
     [Cur ((compile pat' e) @ [Return])]
  | (MLapp(e1,e2)) ->
     if is_constant e1 then (compile pat e2) @ (trans_constant e1)
     else [Push] @ (compile pat e1) @ [Swap] @ (compile pat e2) @ [Cons; App]
  | e ->
     if is_constant e then [Cur (Snd :: trans_constant e)] else failwith "compile"
and is_constant e = List.mem e [MLplus; MLequal; MLfst; MLsnd]
and trans_constant = fun w ->
  match w with
  | MLplus -> [Plus]
  | MLequal -> [Eq]
  | MLfst -> [Fst]
  | MLsnd -> [Snd]
  | _ -> failwith "trans_constant";;

let run : expr -> config = fun e -> exec_code(compile Nullpat e);;

(*
  let x = 5 in
    let z y = y + x in
      let x = 1 in
        let r = z x in r + r    ## 12
*)
run(
    MLin(MLlet(Varpat "x", MLint 5),
         MLin(MLlet(Varpat "z", MLabstr(Varpat "y",MLapp(MLplus, MLpair(MLvar "y", MLvar "x")))),
              MLin(MLlet(Varpat "x", MLint 1),
                   MLin(MLlet(Varpat "r", MLapp(MLvar "z", MLvar "x")),
                        MLapp(MLplus, MLpair(MLvar "r", MLvar "r"))
                  ))
        ))
  );;