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   ; frame_access : Frame.access
  52   }
  53
  54 let alloc_local ~level ~escapes =
  55   { level
  56   ; frame_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 rec seq = function
  66   (* TODO: Is appending 0 OK? How else can the empty case be handled? *)
  67   | []      -> T.EXP (T.CONST 0)
  68   | s :: ss -> T.SEQ (s, seq ss)
  69
  70 let cond_stm gen_stm =
  71   let t = Temp.Label.gen () in
  72   let f = Temp.Label.gen () in
  73   let r = Temp.Temp.gen () in
  74   let stms =
  75     [ T.MOVE (T.TEMP r, T.CONST 1)
  76     ; gen_stm (t, f)
  77     ; T.LABEL f
  78     ; T.MOVE (T.TEMP r, T.CONST 0)
  79     ; T.LABEL t
  80     ]
  81   in
  82   (seq stms, T.TEMP r)
  83
  84 let unEx = function
  85   | Ex exp -> exp
  86   | Nx stm -> T.ESEQ (stm, T.CONST 0)
  87   | Cx gen ->
  88       let stm, exp = cond_stm gen in
  89       T.ESEQ (stm, exp)
  90
  91 let unNx = function
  92   | Ex exp -> T.EXP exp
  93   | Nx stm -> stm
  94   | Cx gen -> fst (cond_stm gen)
  95
  96 let unCx = function
  97   (* "should never occur in compiling a well typed Tiger program" p.154 *)
  98   | Nx _ -> assert false
  99   | Ex e -> fun (_, _) -> T.EXP e  (* TODO: Is this right? *)
 100   | Cx g -> g
 101
 102 let dummy__FIXME = Ex (T.CONST 0)