From d64cf13d30b27d794ba5f5e982754b9e21271aa0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=C5=81ukasz=20Czajka?=
 <62751+lukaszcz@users.noreply.github.com>
Date: Mon, 5 Sep 2022 16:52:41 +0200
Subject: [PATCH] Eager evaluation of Constr arguments (#1513)

---
 src/Juvix/Compiler/Core/Evaluator.hs | 18 ++++++++++--------
 src/Juvix/Prelude/Base.hs            | 18 ++++++++++++++++--
 tests/Core/positive/out/test034.out  |  7 +++++++
 tests/Core/positive/test034.jvc      |  9 ++++++++-
 4 files changed, 41 insertions(+), 11 deletions(-)

diff --git a/src/Juvix/Compiler/Core/Evaluator.hs b/src/Juvix/Compiler/Core/Evaluator.hs
index b6caf18ce..6e20fb994 100644
--- a/src/Juvix/Compiler/Core/Evaluator.hs
+++ b/src/Juvix/Compiler/Core/Evaluator.hs
@@ -62,7 +62,7 @@ eval !ctx !env0 = convertRuntimeNodes . eval' env0
           Closure env' (Lambda _ b) -> let !v = eval' env r in eval' (v : env') b
           v -> evalError "invalid application" (mkApp i v (substEnv env r))
       NBlt (BuiltinApp _ op args) -> applyBuiltin n env op args
-      NCtr (Constr i tag args) -> mkConstr i tag (map (eval' env) args)
+      NCtr (Constr i tag args) -> mkConstr i tag (map' (eval' env) args)
       NLam l@Lambda {} -> Closure env l
       NLet (Let _ v b) -> let !v' = eval' env v in eval' (v' : env) b
       NCase (Case i v bs def) ->
@@ -71,7 +71,7 @@ eval !ctx !env0 = convertRuntimeNodes . eval' env0
           v' -> evalError "matching on non-data" (substEnv env (mkCase i v' bs def))
       NPi {} -> substEnv env n
       NUniv {} -> n
-      NTyp (TypeConstr i sym args) -> mkTypeConstr i sym (map (eval' env) args)
+      NTyp (TypeConstr i sym args) -> mkTypeConstr i sym (map' (eval' env) args)
       Closure {} -> n
 
     branch :: Node -> Env -> [Node] -> Tag -> Maybe Node -> [CaseBranch] -> Node
@@ -87,13 +87,15 @@ eval !ctx !env0 = convertRuntimeNodes . eval' env0
     applyBuiltin _ env OpIntSub [l, r] = nodeFromInteger (integerFromNode (eval' env l) - integerFromNode (eval' env r))
     applyBuiltin _ env OpIntMul [l, r] = nodeFromInteger (integerFromNode (eval' env l) * integerFromNode (eval' env r))
     applyBuiltin n env OpIntDiv [l, r] =
-      case integerFromNode (eval' env r) of
-        0 -> evalError "division by zero" (substEnv env n)
-        k -> nodeFromInteger (div (integerFromNode (eval' env l)) k)
+      let !vl = eval' env l
+       in case integerFromNode (eval' env r) of
+            0 -> evalError "division by zero" (substEnv env n)
+            k -> nodeFromInteger (div (integerFromNode vl) k)
     applyBuiltin n env OpIntMod [l, r] =
-      case integerFromNode (eval' env r) of
-        0 -> evalError "division by zero" (substEnv env n)
-        k -> nodeFromInteger (mod (integerFromNode (eval' env l)) k)
+      let !vl = eval' env l
+       in case integerFromNode (eval' env r) of
+            0 -> evalError "division by zero" (substEnv env n)
+            k -> nodeFromInteger (mod (integerFromNode vl) k)
     applyBuiltin _ env OpIntLt [l, r] = nodeFromBool (integerFromNode (eval' env l) < integerFromNode (eval' env r))
     applyBuiltin _ env OpIntLe [l, r] = nodeFromBool (integerFromNode (eval' env l) <= integerFromNode (eval' env r))
     applyBuiltin _ env OpEq [l, r] = nodeFromBool (structEq (eval' env l) (eval' env r))
diff --git a/src/Juvix/Prelude/Base.hs b/src/Juvix/Prelude/Base.hs
index 4a8246507..3ddb78943 100644
--- a/src/Juvix/Prelude/Base.hs
+++ b/src/Juvix/Prelude/Base.hs
@@ -1,3 +1,9 @@
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Avoid restricted extensions" #-}
+{-# HLINT ignore "Avoid restricted flags" #-}
+
 module Juvix.Prelude.Base
   ( module Juvix.Prelude.Base,
     module Control.Applicative,
@@ -223,8 +229,16 @@ tableNestedInsert k1 k2 = tableInsert (HashMap.singleton k2) (HashMap.insert k2)
 --------------------------------------------------------------------------------
 
 revAppend :: [a] -> [a] -> [a]
-revAppend [] ys = ys
-revAppend (x : xs) ys = revAppend xs (x : ys)
+revAppend [] !ys = ys
+revAppend (x : xs) !ys = revAppend xs (x : ys)
+
+map' :: (a -> b) -> [a] -> [b]
+map' _ [] = []
+map' f (h : t) =
+  -- keeping the lets separate ensures that `v` is evaluated before `vs`
+  let !v = f h
+   in let !vs = map' f t
+       in v : vs
 
 --------------------------------------------------------------------------------
 -- NonEmpty
diff --git a/tests/Core/positive/out/test034.out b/tests/Core/positive/out/test034.out
index f5308ca63..b4384df07 100644
--- a/tests/Core/positive/out/test034.out
+++ b/tests/Core/positive/out/test034.out
@@ -1,3 +1,10 @@
+!
+0
+a
+b
+c
+d
+0
 1
 2
 3
diff --git a/tests/Core/positive/test034.jvc b/tests/Core/positive/test034.jvc
index 8a09945f5..6efaa954c 100644
--- a/tests/Core/positive/test034.jvc
+++ b/tests/Core/positive/test034.jvc
@@ -10,7 +10,14 @@ def f := \x \y
 
 def h := \x trace 8 (trace x (x + x));
 
+def const := \x \y x;
+
+constr nil 0;
+constr cons 2;
+
+trace (const 0 (trace "!" 1)) (
+trace (const 0 (cons (trace "a" 1) (trace "b" (cons (trace "c" 1) (trace "d" nil))))) (
 trace ((\x \y \z x + y + z) (trace "1" 1) (trace "2" 2) (trace "3" 3)) (
 trace (f 5 g) (trace 7 (
 h (trace 2 3)
-)))
+)))))