X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Normalize.hs;h=e0591a87e222c5dfff98d2df755de9bf26d091a6;hb=f2ce393c85a9ccb673f8ba2df12b7c5b649c3a34;hp=eab4ff70654d0900eb4c8b3787fe8bc02d725d72;hpb=f821a93d2c6a15c8640131f1e54d3dbb5477301d;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Normalize.hs b/Normalize.hs
index eab4ff7..e0591a8 100644
--- a/Normalize.hs
+++ b/Normalize.hs
@@ -436,18 +436,24 @@ funextract expr@(App _ _) | is_var fexpr = do
     -- Find the function called and the arguments
     (fexpr, args) = collectArgs expr
     Var f = fexpr
-    -- Leave simple arguments untouched
-    doarg (Var arg) = return $ Var arg
-    -- Change any arguments that have a function type, but no free variables.
-    -- We could use is_applicable here, but I think arguments to functions
-    -- could only have forall typing when existential typing is enabled. Not
-    -- sure, though.
-    doarg arg | is_fun arg && not (has_free_vars arg) = do
-      -- Create a new top level binding that binds the argument
-      id <- mkBinderFor arg "fun"
-      Trans.lift $ addGlobalBind id arg
-      -- Replace the argument with a reference to the argument
-      change $ Var id
+    -- Change any arguments that have a function type, but are not simple yet
+    -- (ie, a variable or application). This means to create a new function
+    -- for map (\f -> ...) b, but not for map (foo a) b.
+    --
+    -- We could use is_applicable here instead of is_fun, but I think
+    -- arguments to functions could only have forall typing when existential
+    -- typing is enabled. Not sure, though.
+    doarg arg | not (is_simple arg) && is_fun arg = do
+      -- Create a new top level binding that binds the argument. Its body will
+      -- be extended with lambda expressions, to take any free variables used
+      -- by the argument expression.
+      let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg
+      let body = MkCore.mkCoreLams free_vars arg
+      id <- mkBinderFor body "fun"
+      Trans.lift $ addGlobalBind id body
+      -- Replace the argument with a reference to the new function, applied to
+      -- all vars it uses.
+      change $ MkCore.mkCoreApps (Var id) (map Var free_vars)
     -- Leave all other arguments untouched
     doarg arg = return arg
 
@@ -497,7 +503,7 @@ normalizeBind bndr =
       then
         -- This should really only happen at the top level... TODO: Give
         -- a different error if this happens down in the recursion.
-        error $ "Function " ++ show bndr ++ " is polymorphic, can't normalize"
+        error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
       else do
         normalized_funcs <- getA tsNormalized
         -- See if this function was normalized already
@@ -531,4 +537,4 @@ normalizeBind bndr =
                 return ()
               -- We don't have a value for this binder. This really shouldn't
               -- happen for local id's...
-              Nothing -> error $ "No value found for binder " ++ pprString bndr ++ "? This should not happen!"
+              Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!"