fix: support recursive let bindings in static code (Fix 402) (#1230)

carp-lang · Jun 5, 2021 · bda32d6 · bda32d6
1 parent 8f055f2
commit bda32d6
Show file tree

Hide file tree

Showing 5 changed files with 65 additions and 4 deletions.
diff --git a/src/Concretize.hs b/src/Concretize.hs
@@ -140,6 +140,11 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
                 SymPath spath name = rootDefinitionPath
                 lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii) ++ "_env")
                 lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing
+                -- Anonymous functions bound to a let name might call themselves. These recursive instances will have already been qualified as LookupRecursive symbols.
+                -- Rename the recursive calls according to the generated lambda name so that we can call these correctly from C.
+                renameRecursives (XObj (Sym _ LookupRecursive) si st) = (XObj (Sym lambdaPath LookupRecursive) si st)
+                renameRecursives x = x
+                recBody = walk renameRecursives okBody
                 environmentTypeName = pathToC lambdaPath ++ "_ty"
                 tyPath = (SymPath [] environmentTypeName)
                 extendedArgs =
@@ -158,7 +163,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
                         )
                         ai
                         at
-                lambdaCallback = XObj (Lst [XObj (Defn (Just (Set.fromList capturedVars))) (Just dummyInfo) Nothing, lambdaNameSymbol, extendedArgs, okBody]) i t
+                lambdaCallback = XObj (Lst [XObj (Defn (Just (Set.fromList capturedVars))) (Just dummyInfo) Nothing, lambdaNameSymbol, extendedArgs, recBody]) i t
                 -- The lambda will also carry with it a special made struct containing the variables it captures
                 -- (if it captures at least one variable)
                 structMemberPairs =
@@ -203,7 +208,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
                               modify (deleterDeps ++)
                               modify (copyFn :)
                               modify (copyDeps ++)
-                      pure (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars)) fni fnt, args, okBody])
+                      pure (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars)) fni fnt, args, recBody])
           Left err ->
             pure (Left err)
     visitList _ Toplevel env (XObj (Lst [def@(XObj Def _ _), nameSymbol, body]) _ t) =

diff --git a/src/InitialTypes.hs b/src/InitialTypes.hs
@@ -212,7 +212,26 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
         [XObj (Defn _) _ _, XObj (Sym _ _) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj))
         XObj defn@(Defn _) _ _ : _ ->
           pure (Left (InvalidObjExample defn xobj "(defn <name> [<arguments>] <body>)"))
-        -- Fn
+        -- Anonymous function bound to a let name
+        -- Supports recursion by assigning the same type to recursive calls ("let-rec").
+        [XObj LocalDef _ _, XObj (Sym path _) si _, XObj (Lst [fn@(XObj (Fn _ _) _ _), XObj (Arr argList) argsi argst, body]) _ _] ->
+          do
+            (argTypes, returnType, funcScopeEnv) <- getTys env argList
+            lt <- genVarTy
+            let funcTy = Just (FuncTy argTypes returnType lt)
+                typedNameSymbol = XObj (Sym path LookupRecursive) si funcTy
+                Right envWithSelf = E.insertX funcScopeEnv path typedNameSymbol
+            visitedBody <- visit envWithSelf body
+            visitedArgs <- mapM (visit envWithSelf) argList
+            pure $ do
+              okBody <- visitedBody
+              okArgs <- sequence visitedArgs
+              let final = XObj (Lst [fn, XObj (Arr okArgs) argsi argst, okBody]) i funcTy
+              pure final --(trace ("FINAL: " ++ show final) final)
+        -- Let bindings
+        [XObj LocalDef _ _, _, value] ->
+          visit env value
+        -- Unbound anonymous Fn
         [fn@(XObj (Fn _ _) _ _), XObj (Arr argList) argsi argst, body] ->
           do
             (argTypes, returnType, funcScopeEnv) <- getTys env argList
@@ -427,6 +446,9 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
        in -- Need to fold (rather than map) to make the previous bindings accessible to the later ones, i.e. (let [a 100 b a] ...)
           foldM createBinderForLetPair (Right emptyInnerEnv) pairs
       where
+        -- Cast binders to Local Defs so that we can account for recursion ("let-rec").
+        -- A local def carries the binder name along with its value, so we can appropriately type recursive uses.
+        -- e.g. (let [f (fn [x] (if (= x 1) x (f (dec x))))])
         createBinderForLetPair :: Either TypeError Env -> (XObj, XObj) -> State Integer (Either TypeError Env)
         createBinderForLetPair envOrErr (sym, expr) =
           case envOrErr of
@@ -435,7 +457,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
               case xobjObj sym of
                 (Sym (SymPath _ name) _) ->
                   do
-                    visited <- visit env' expr
+                    visited <- visit env' (toLocalDef name expr)
                     pure
                       ( join
                           (replaceLeft (InvalidLetBinding xobjs (sym, expr)) . E.insert env' (SymPath [] name) . Binder emptyMeta <$> visited)

diff --git a/src/Obj.hs b/src/Obj.hs
@@ -1121,3 +1121,10 @@ trueXObj = XObj (Bol True) Nothing Nothing
 -- | Dynamic 'false'.
 falseXObj :: XObj
 falseXObj = XObj (Bol False) Nothing Nothing
+
+-- | Applies an XObj transformation over all atomic XObjs in a form, retaining
+-- list and array structure.
+walk :: (XObj -> XObj) -> XObj -> XObj
+walk f (XObj (Arr xs) i t) = XObj (Arr (map (walk f) xs)) i t
+walk f (XObj (Lst xs) i t) = XObj (Lst (map (walk f) xs)) i t
+walk f x = f x
diff --git a/src/Qualify.hs b/src/Qualify.hs
@@ -253,6 +253,24 @@ qualifyLet typeEnv globalEnv env x@(XObj (Lst [letExpr@(XObj Let _ _), bind@(XOb
       pure (Qualified (XObj (Lst [letExpr, XObj (Arr qualifiedBindings) bindi bindt, qualifiedBody]) i t))
   where
     qualifyBinding :: (Env, [XObj]) -> (XObj, XObj) -> Either QualificationError (Env, [XObj])
+    qualifyBinding (e, bs) (s@(XObj (Sym path _) _ _), o@(XObj (Lst [(XObj (Fn _ _) _ _), _, _]) _ _)) =
+      do
+        -- Let bindings to anonymous functions may recursively call themselves,
+        -- qualify the symbols appropriately by adding a recursion environment.
+        -- e.g. (let [f (fn [x] (if (= x 1) x (f (dec x))))])
+        -- Environment parenting is a bit nuanced here; the recursive reference
+        -- needs to be stored in a recursive env to mark the symbol correctly.
+        -- However, we also need to ensure captured variables are still marked
+        -- as such, which is based on env nesting level, and we need to ensure
+        -- the recursive reference isn't accidentally captured.
+        let Just origin = E.parent e
+        recursionEnv <- fixLeft (pure (E.recursive (Just e) (Just ("let-recurse-env")) 0))
+        envWithSelf <- fixLeft (E.insertX recursionEnv path s)
+        qualified <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv (E.setParent e (E.setParent origin envWithSelf)) o)
+        updated <- (replaceLeft (FailedToQualifySymbols x) (E.insertX e path s))
+        (pure (updated, bs ++ [s, qualified]))
+      where
+        fixLeft = replaceLeft (FailedToQualifyDeclarationName x)
     qualifyBinding (e, bs) (s@(XObj (Sym path _) _ _), o) =
       do
         qualified <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv e o)

diff --git a/test/recursion.carp b/test/recursion.carp
@@ -21,6 +21,11 @@
 (defn recursion-test-2 []
   (A.flurb 9 6))
 
+;; let bindings may be recursive in static contexts (issue #402)
+(defn letrec-test []
+  (let [f (fn [x] (if (= x 1) x (f (dec x))))]
+    (f 10)))
+
 (deftest test
   (assert-equal test
                 120
@@ -30,4 +35,8 @@
                 35
                 (recursion-test-2)
                 "Ensure that problem with recursion in modules is resolved.")
+  (assert-equal test
+                1
+                (letrec-test)
+                "Let bindings bound to lambdas can call themselves ('let-rec' support)")
   )