compiler/src/lib/tiger/tiger_translate.ml

   1 module List = ListLabels
   2
   3 module Frame = Tiger_frame
   4 module Temp  = Tiger_temp
   5 module T     = Tiger_tree
   6
   7 module Level = struct
   8   type t =
   9     { parent  : t option
  10     ; name    : Temp.Label.t
  11     ; formals : bool list
  12     ; frame   : Frame.t
  13     }
  14
  15   let init =
  16     let name    = Temp.Label.gen () in
  17     let formals = [] in
  18     { parent  = None
  19     ; name
  20     ; formals
  21     ; frame   = Frame.make ~name ~formals
  22     }
  23
  24   let next t ~name  ~formals =
  25     (* Adding the extra parameter for the static link. See p. 142 *)
  26     let formals = true :: formals in
  27     { parent = Some t
  28     ; name
  29     ; formals
  30     ; frame = Frame.make ~name ~formals
  31     }
  32
  33   let formals = function {formals; _} ->
  34     formals
  35
  36   let frame = function {frame; _} ->
  37     frame
  38 end
  39
  40 type gen_stm =
  41   (Tiger_temp.Label.t * Tiger_temp.Label.t) -> Tiger_tree.stm
  42
  43 type exp =
  44   | Ex of Tiger_tree.exp
  45   | Nx of Tiger_tree.stm
  46   | Cx of gen_stm
  47
  48 type access =
  49   (* must know about static links *)
  50   { level  : Level.t
  51   ; access : Frame.access
  52   }
  53
  54 let alloc_local ~level ~escapes =
  55   { level
  56   ; access = Frame.alloc_local (Level.frame level) ~escapes
  57   }
  58
  59 let formals ~level =
  60   (* FIXME: This seems wrong. Should we call Frame.formals? *)
  61   List.map (Level.formals level) ~f:(fun escapes ->
  62     alloc_local ~level ~escapes
  63   )
  64
  65 let not_implemented func =
  66   failwith (Printf.sprintf "Not implemented: %s.%s" __MODULE__ func)
  67
  68 let rec seq = function
  69   (* TODO: Is appending 0 OK? How else can the empty case be handled? *)
  70   | []      -> T.EXP (T.CONST 0)
  71   | s :: ss -> T.SEQ (s, seq ss)
  72
  73 let cond_stm gen_stm =
  74   let t = Temp.Label.gen () in
  75   let f = Temp.Label.gen () in
  76   let r = Temp.Temp.gen () in
  77   let stms =
  78     [ T.MOVE (T.TEMP r, T.CONST 1)
  79     ; gen_stm (t, f)
  80     ; T.LABEL f
  81     ; T.MOVE (T.TEMP r, T.CONST 0)
  82     ; T.LABEL t
  83     ]
  84   in
  85   (seq stms, T.TEMP r)
  86
  87 let unEx = function
  88   | Ex exp -> exp
  89   | Nx stm -> T.ESEQ (stm, T.CONST 0)
  90   | Cx gen ->
  91       let stm, exp = cond_stm gen in
  92       T.ESEQ (stm, exp)
  93
  94 let unNx = function
  95   | Ex exp -> T.EXP exp
  96   | Nx stm -> stm
  97   | Cx gen -> fst (cond_stm gen)
  98
  99 let unCx = function
 100   (* "should never occur in compiling a well typed Tiger program" p.154 *)
 101   | Nx _ -> assert false
 102   | Ex e -> fun (_, _) -> T.EXP e  (* TODO: Is this right? *)
 103   | Cx g -> g
 104
 105 let dummy__FIXME = Ex (T.CONST 0)
 106
 107 let simple_var {level; access} =
 108   let pointer = not_implemented "simple_var frame pointer" in
 109   Ex (Frame.exp ~access ~pointer)