src/run.ml

   1 (* Goalfile run
   2  * Copyright (C) 2019 Richard W.M. Jones
   3  * Copyright (C) 2019 Red Hat Inc.
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2 of the License, or
   8  * (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License along
  16  * with this program; if not, write to the Free Software Foundation, Inc.,
  17  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  18  *)
  19
  20 open Printf
  21
  22 open Utils
  23
  24 let rec goal_runner env loc name args
  25                     (params, patterns, deps, code) extra_deps debug_goal =
  26   Cmdline.debug "%a: running goal %s" Ast.string_loc loc debug_goal;
  27
  28   (* Check if any target (ie. pattern) needs to be rebuilt.
  29    * As with make, a goal with no targets is always run.
  30    *)
  31   let rebuild =
  32     patterns = [] ||
  33     List.exists (needs_rebuild env loc deps extra_deps) patterns in
  34
  35   if rebuild then (
  36     (* Run the code (if any). *)
  37     (match code with
  38      | None -> () (* No { CODE } section. *)
  39
  40      | Some code ->
  41         (* Add some standard variables to the environment. *)
  42         let expr_of_substs s = Ast.ESubsts (Ast.noloc, s) in
  43         let expr_of_pattern = function
  44           | Ast.PPred (loc, pred, targs) ->
  45              Ast.EPredCtor (loc, pred, List.map expr_of_substs targs)
  46         in
  47         let pexprs = List.map expr_of_pattern patterns in
  48         let env = Ast.Env.add "@" (Ast.EList (Ast.noloc, pexprs)) env in
  49         let env = Ast.Env.add "<" (Ast.EList (Ast.noloc, deps)) env in
  50         let env =
  51           (* NB: extra_deps are not added to %^ *)
  52           match deps with
  53           | [] -> env
  54           | d :: _ -> Ast.Env.add "^" d env in
  55         let r = Eval.run_code env loc code in
  56         if r <> 0 then
  57           failwithf "%a: goal ‘%s’ failed with exit code %d"
  58             Ast.string_loc loc debug_goal r;
  59
  60         (* Check all targets were updated after the code was
  61          * run (else it's an error).
  62          *)
  63         let pattern_still_needs_rebuild =
  64           try
  65             let pattern =
  66               List.find
  67                 (needs_rebuild ~final_check:true env loc deps extra_deps)
  68                 patterns in
  69             Some pattern
  70           with
  71             Not_found -> None in
  72         match pattern_still_needs_rebuild with
  73         | None -> ()
  74         | Some pattern ->
  75            failwithf "%a: goal ‘%s’ ran successfully but it did not rebuild %a"
  76              Ast.string_loc loc debug_goal Ast.string_pattern pattern
  77     )
  78   )
  79
  80 (* Return whether the target (pattern) needs to be rebuilt. *)
  81 and needs_rebuild ?(final_check = false) env loc deps extra_deps pattern =
  82   Cmdline.debug "%a: testing if %a needs rebuild"
  83     Ast.string_loc loc Ast.string_pattern pattern;
  84
  85   match pattern with
  86   | Ast.PPred (loc, pred, targs) ->
  87      (* Look up the predicate. *)
  88      let params, code = Ast.getpred env loc pred in
  89
  90      (* Resolve the targs down to constants.  Since needs_rebuild
  91       * should be called with env containing the goal params, this
  92       * should substitute any parameters in the predicate arguments.
  93       *)
  94      let targs = List.map (Eval.substitute env loc) targs in
  95      let targs =
  96        List.map (fun targ ->
  97            Ast.EConstant (Ast.noloc, Ast.CString targ)) targs in
  98
  99      (* Create a new environment binding parameter names
 100       * to predicate args.
 101       *)
 102      let env =
 103        let params =
 104          try List.combine params targs
 105          with Invalid_argument _ ->
 106            failwithf "%a: calling predicate ‘%s’ with wrong number of arguments"
 107              Ast.string_loc loc pred in
 108        List.fold_left (fun env (k, v) -> Ast.Env.add k v env) env params in
 109
 110      (* Add some standard variables to the environment. *)
 111      let env = Ast.Env.add "<" (Ast.EList (Ast.noloc, deps)) env in
 112      let env =
 113        (*let b = Ast.EConstant (Ast.noloc, Ast.CBool final_check) in*)
 114        let b = Ast.EConstant (Ast.noloc,
 115                               Ast.CString (if final_check then "1" else "")) in
 116        Ast.Env.add "goals_final_check" b env in
 117      let env =
 118        (* NB: extra_deps are not added to %^ *)
 119        match deps with
 120        | [] -> env
 121        | d :: _ -> Ast.Env.add "^" d env in
 122      let r = Eval.run_code env loc code in
 123      if r = 99 (* means "needs rebuild" *) then true
 124      else if r = 0 (* means "doesn't need rebuild" *) then false
 125      else (
 126        let targs = List.map (Ast.string_expr ()) targs in
 127        let targs = String.concat ", " targs in
 128        failwithf "%a: predicate ‘%s (%s)’ failed with exit code %d"
 129          Ast.string_loc loc pred targs r
 130      )
 131
 132 and exists_runner env loc p debug_pred =
 133   Cmdline.debug "%a: running implicit existence rule for predicate %s"
 134     Ast.string_loc loc debug_pred;
 135
 136   if needs_rebuild env loc [] [] p then
 137     failwithf "%a: don't know how to build ‘%s’"
 138       Ast.string_loc loc debug_pred