Fix deadlocks [Rebased, Squashed] (#1536)

Co-authored-by: Arnaud Bailly <[email protected]>
Co-authored-by: Guillaume Allais <[email protected]>
Co-authored-by: Fabián Heredia Montiel <[email protected]>
Co-authored-by: Ruslan Feizerakhmanov <[email protected]>

Author: 4 people

.github/workflows/ci-ubuntu-combined.yml

@@ -31,7 +31,9 @@ jobs:
         uses: actions/checkout@v2
       - name: Install build dependencies
         run: |
-          sudo apt-get install -y chezscheme
+          echo "deb http://security.ubuntu.com/ubuntu hirsute universe" | sudo tee -a /etc/apt/sources.list
+          sudo apt-get update
+          sudo apt-get install -y -t hirsute chezscheme
           echo "$HOME/.idris2/bin" >> $GITHUB_PATH
       - name: Build from bootstrap
         run: make bootstrap && make install
@@ -71,14 +73,16 @@ jobs:
         uses: actions/checkout@v2
       - name: Install build dependencies
         run: |
-          sudo apt-get install -y chezscheme
+          echo "deb http://security.ubuntu.com/ubuntu hirsute universe" | sudo tee -a /etc/apt/sources.list
+          sudo apt-get update
+          sudo apt-get install -y -t hirsute chezscheme
           echo "$HOME/.idris2/bin" >> $GITHUB_PATH
       - name: Cache Chez Previous Version
         id: previous-version-cache
         uses: actions/cache@v2
         with:
           path: Idris2-${{ env.IDRIS2_VERSION }}
-          key: ${{ runner.os }}-idris2-bootstrapped-${{ env.IDRIS2_VERSION }}
+          key: ${{ runner.os }}-idris2-bootstrapped-hirsute-chez-${{ env.IDRIS2_VERSION }}
       - name : Build previous version
         if: steps.previous-version-cache.outputs.cache-hit != 'true'
         run: |
@@ -118,7 +122,9 @@ jobs:
           path: ~/.idris2/
       - name: Install build dependencies
         run: |
-          sudo apt-get install -y chezscheme
+          echo "deb http://security.ubuntu.com/ubuntu hirsute universe" | sudo tee -a /etc/apt/sources.list
+          sudo apt-get update
+          sudo apt-get install -y -t hirsute chezscheme
           echo "$HOME/.idris2/bin" >> $GITHUB_PATH
           chmod +x $HOME/.idris2/bin/idris2 $HOME/.idris2/bin/idris2_app/*
       - name: Build self-hosted
@@ -166,7 +172,9 @@ jobs:
           path: ~/.idris2/
       - name: Install build dependencies
         run: |
-          sudo apt-get install -y chezscheme
+          echo "deb http://security.ubuntu.com/ubuntu hirsute universe" | sudo tee -a /etc/apt/sources.list
+          sudo apt-get update
+          sudo apt-get install -y -t hirsute chezscheme
           echo "$HOME/.idris2/bin" >> $GITHUB_PATH
           chmod +x $HOME/.idris2/bin/idris2 $HOME/.idris2/bin/idris2_app/*
       - name: Build from previous version
@@ -197,7 +205,9 @@ jobs:
           path: ~/.idris2/
       - name: Install build dependencies
         run: |
-          sudo apt-get install -y chezscheme
+          echo "deb http://security.ubuntu.com/ubuntu hirsute universe" | sudo tee -a /etc/apt/sources.list
+          sudo apt-get update
+          sudo apt-get install -y -t hirsute chezscheme
           echo "$HOME/.idris2/bin" >> $GITHUB_PATH
           chmod +x $HOME/.idris2/bin/idris2 $HOME/.idris2/bin/idris2_app/*
       - name: Build API

idris2api.ipkg

@@ -132,6 +132,7 @@ modules =
     Libraries.Data.String.Iterator,
     Libraries.Data.StringMap,
     Libraries.Data.StringTrie,
+    Libraries.Data.Version,
 
     Libraries.System.Directory.Tree,
 

libs/network/Network/FFI.idr

@@ -57,7 +57,8 @@ prim__idrnet_sockaddr_port : (sockfd : SocketDescriptor) -> PrimIO Int
 export
 prim__idrnet_create_sockaddr : PrimIO AnyPtr
 
-%foreign "C:idrnet_accept, libidris2_support, idris_net.h"
+%foreign "C__collect_safe:idrnet_accept, libidris2_support, idris_net.h"
+         "C:idrnet_accept, libidris2_support, idris_net.h"
 export
 prim__idrnet_accept : (sockfd : SocketDescriptor) -> (sockaddr : AnyPtr) -> PrimIO Int
 
@@ -70,11 +71,13 @@ export
 prim__idrnet_send_buf : (sockfd : SocketDescriptor) -> (dataBuffer : AnyPtr) -> (len : Int) -> PrimIO Int
 
 
-%foreign "C:idrnet_recv, libidris2_support, idris_net.h"
+%foreign "C__collect_safe:idrnet_recv, libidris2_support, idris_net.h"
+         "C:idrnet_recv, libidris2_support, idris_net.h"
 export
 prim__idrnet_recv : (sockfd : SocketDescriptor) -> (len : Int) -> PrimIO AnyPtr
 
-%foreign "C:idrnet_recv_buf, libidris2_support, idris_net.h"
+%foreign "C__collect_safe:idrnet_recv_buf, libidris2_support, idris_net.h"
+         "C:idrnet_recv_buf, libidris2_support, idris_net.h"
 export
 prim__idrnet_recv_buf : (sockfd : SocketDescriptor) -> (buf : AnyPtr) -> (len : Int) -> PrimIO Int
 
@@ -89,11 +92,13 @@ prim__idrnet_sendto_buf : (sockfd : SocketDescriptor) -> (dataBuf : AnyPtr) ->
                           (buf_len : Int) -> (host : String) -> (port : Port) ->
                           (family : Int) -> PrimIO Int
 
-%foreign "C:idrnet_recvfrom, libidris2_support, idris_net.h"
+%foreign "C__collect_safe:idrnet_recvfrom, libidris2_support, idris_net.h"
+         "C:idrnet_recvfrom, libidris2_support, idris_net.h"
 export
 prim__idrnet_recvfrom : (sockfd : SocketDescriptor) -> (len : Int) -> PrimIO AnyPtr
 
-%foreign "C:idrnet_recvfrom_buf, libidris2_support, idris_net.h"
+%foreign "C__collect_safe:idrnet_recvfrom_buf, libidris2_support, idris_net.h"
+         "C:idrnet_recvfrom_buf, libidris2_support, idris_net.h"
 export
 prim__idrnet_recvfrom_buf : (sockfd : SocketDescriptor) -> (buf : AnyPtr) -> (len : Int) -> PrimIO AnyPtr
 

src/Compiler/Scheme/Chez.idr

@@ -18,6 +18,7 @@ import Data.List
 import Data.List1
 import Data.Maybe
 import Libraries.Data.NameMap
+import Libraries.Data.Version
 import Data.Strings
 import Data.Vect
 
@@ -38,6 +39,28 @@ findChez
          path <- pathLookup ["chez", "chezscheme9.5", "scheme"]
          pure $ fromMaybe "/usr/bin/env scheme" path
 
+||| Returns the chez scheme version for given executable
+|||
+||| This uses `chez --version` which unfortunately writes the version
+||| on `stderr` thus requiring suffixing the command which shell redirection
+||| which does not seem very portable.
+export
+chezVersion : String -> IO (Maybe Version)
+chezVersion chez = do
+    Right fh <- popen cmd Read
+        | Left err => pure Nothing
+    Right output <- fGetLine fh
+        | Left err => pure Nothing
+    pclose fh
+    pure $ parseVersion output
+  where
+  cmd : String
+  cmd = chez ++ " --version 2>&1"
+
+unsupportedCallingConvention : Maybe Version -> Bool
+unsupportedCallingConvention Nothing = True
+unsupportedCallingConvention (Just version) = version < MkVersion (9,5,0) Nothing
+
 -- Given the chez compiler directives, return a list of pairs of:
 --   - the library file name
 --   - the full absolute path of the library file name, if it's in one
@@ -197,19 +220,25 @@ cftySpec fc (CFStruct n t) = pure $ "(* " ++ n ++ ")"
 cftySpec fc t = throw (GenericMsg fc ("Can't pass argument of type " ++ show t ++
                          " to foreign function"))
 
-cCall : {auto c : Ref Ctxt Defs} ->
-        {auto l : Ref Loaded (List String)} ->
-        String -> FC -> (cfn : String) -> (clib : String) ->
-        List (Name, CFType) -> CFType -> Core (String, String)
-cCall appdir fc cfn clib args (CFIORes CFGCPtr)
+cCall : {auto c : Ref Ctxt Defs}
+     -> {auto l : Ref Loaded (List String)}
+     -> String
+     -> FC
+     -> (cfn : String)
+     -> (clib : String)
+     -> List (Name, CFType)
+     -> CFType
+     -> (collectSafe : Bool)
+     -> Core (String, String)
+cCall appdir fc cfn clib args (CFIORes CFGCPtr) _
     = throw (GenericMsg fc "Can't return GCPtr from a foreign function")
-cCall appdir fc cfn clib args CFGCPtr
+cCall appdir fc cfn clib args CFGCPtr _
     = throw (GenericMsg fc "Can't return GCPtr from a foreign function")
-cCall appdir fc cfn clib args (CFIORes CFBuffer)
+cCall appdir fc cfn clib args (CFIORes CFBuffer) _
     = throw (GenericMsg fc "Can't return Buffer from a foreign function")
-cCall appdir fc cfn clib args CFBuffer
+cCall appdir fc cfn clib args CFBuffer _
     = throw (GenericMsg fc "Can't return Buffer from a foreign function")
-cCall appdir fc cfn clib args ret
+cCall appdir fc cfn clib args ret collectSafe
     = do loaded <- get Loaded
          lib <- if clib `elem` loaded
                    then pure ""
@@ -221,7 +250,8 @@ cCall appdir fc cfn clib args ret
                                     ++ "\")\n"
          argTypes <- traverse (\a => cftySpec fc (snd a)) args
          retType <- cftySpec fc ret
-         let call = "((foreign-procedure #f " ++ show cfn ++ " ("
+         let callConv = if collectSafe then " __collect_safe" else ""
+         let call = "((foreign-procedure" ++ callConv ++ " " ++ show cfn ++ " ("
                       ++ showSep " " argTypes ++ ") " ++ retType ++ ") "
                       ++ showSep " " !(traverse buildArg args) ++ ")"
 
@@ -282,19 +312,23 @@ schemeCall fc sfn argns ret
 -- function call.
 useCC : {auto c : Ref Ctxt Defs} ->
         {auto l : Ref Loaded (List String)} ->
-        String -> FC -> List String -> List (Name, CFType) -> CFType -> Core (String, String)
-useCC appdir fc ccs args ret
-    = case parseCC ["scheme,chez", "scheme", "C"] ccs of
-           Nothing => throw (NoForeignCC fc)
+        String -> FC -> List String -> List (Name, CFType) -> CFType ->
+        Maybe Version -> Core (String, String)
+useCC appdir fc ccs args ret version
+    = case parseCC ["scheme,chez", "scheme", "C__collect_safe", "C"] ccs of
            Just ("scheme,chez", [sfn]) =>
                do body <- schemeCall fc sfn (map fst args) ret
                   pure ("", body)
            Just ("scheme", [sfn]) =>
                do body <- schemeCall fc sfn (map fst args) ret
                   pure ("", body)
-           Just ("C", [cfn, clib]) => cCall appdir fc cfn clib args ret
-           Just ("C", [cfn, clib, chdr]) => cCall appdir fc cfn clib args ret
-           _ => throw (NoForeignCC fc)
+           Just ("C__collect_safe", (cfn :: clib :: _)) => do
+             if unsupportedCallingConvention version
+               then cCall appdir fc cfn clib args ret False
+               else cCall appdir fc cfn clib args ret True
+           Just ("C", (cfn :: clib :: _)) =>
+             cCall appdir fc cfn clib args ret False
+           _ => throw (NoForeignCC fc ccs)
 
 -- For every foreign arg type, return a name, and whether to pass it to the
 -- foreign call (we don't pass '%World')
@@ -323,28 +357,28 @@ mkStruct _ = pure ""
 schFgnDef : {auto c : Ref Ctxt Defs} ->
             {auto l : Ref Loaded (List String)} ->
             {auto s : Ref Structs (List String)} ->
-            String -> FC -> Name -> NamedDef -> Core (String, String)
-schFgnDef appdir fc n (MkNmForeign cs args ret)
+            String -> FC -> Name -> NamedDef -> Maybe Version -> Core (String, String)
+schFgnDef appdir fc n (MkNmForeign cs args ret) version
     = do let argns = mkArgs 0 args
          let allargns = map fst argns
          let useargns = map fst (filter snd argns)
          argStrs <- traverse mkStruct args
          retStr <- mkStruct ret
-         (load, body) <- useCC appdir fc cs (zip useargns args) ret
+         (load, body) <- useCC appdir fc cs (zip useargns args) ret version
          defs <- get Ctxt
          pure (load,
                 concat argStrs ++ retStr ++
                 "(define " ++ schName !(full (gamma defs) n) ++
                 " (lambda (" ++ showSep " " (map schName allargns) ++ ") " ++
                 body ++ "))\n")
-schFgnDef _ _ _ _ = pure ("", "")
+schFgnDef _ _ _ _ _ = pure ("", "")
 
 export
 getFgnCall : {auto c : Ref Ctxt Defs} ->
              {auto l : Ref Loaded (List String)} ->
              {auto s : Ref Structs (List String)} ->
-             String -> (Name, FC, NamedDef) -> Core (String, String)
-getFgnCall appdir (n, fc, d) = schFgnDef appdir fc n d
+             String -> Maybe Version -> (Name, FC, NamedDef) -> Core (String, String)
+getFgnCall appdir version (n, fc, d) = schFgnDef appdir fc n d version
 
 export
 startChezPreamble : String
@@ -401,11 +435,12 @@ compileToSS c prof appdir tm outfile
          defs <- get Ctxt
          l <- newRef {t = List String} Loaded ["libc", "libc 6"]
          s <- newRef {t = List String} Structs []
-         fgndefs <- traverse (getFgnCall appdir) ndefs
+         chez <- coreLift findChez
+         version <- coreLift $ chezVersion chez
+         fgndefs <- traverse (getFgnCall appdir version) ndefs
          compdefs <- traverse (getScheme chezExtPrim chezString) ndefs
          let code = fastAppend (map snd fgndefs ++ compdefs)
          main <- schExp chezExtPrim chezString 0 ctm
-         chez <- coreLift findChez
          support <- readDataFile "chez/support.ss"
          extraRuntime <- getExtraRuntime ds
          let scm = schHeader chez (map snd libs) ++

src/Compiler/Scheme/ChezSep.idr

@@ -22,6 +22,7 @@ import Data.List
 import Data.List1
 import Data.Maybe
 import Libraries.Data.NameMap
+import Libraries.Data.Version
 import Data.Strings
 import Data.Vect
 
@@ -150,6 +151,7 @@ compileToSS c chez appdir tm = do
   ds <- getDirectives Chez
   libs <- findLibs ds
   traverse_ copyLib libs
+  version <- coreLift $ chezVersion chez
 
   -- get the material for compilation
   cdata <- getCompileData False Cases tm
@@ -213,7 +215,7 @@ compileToSS c chez appdir tm = do
             ++ "  (import (chezscheme) (support) " ++ imports ++ ")\n\n"
       let footer = ")"
 
-      fgndefs <- traverse (Chez.getFgnCall appdir) cu.definitions
+      fgndefs <- traverse (Chez.getFgnCall appdir version) cu.definitions
       compdefs <- traverse (getScheme Chez.chezExtPrim Chez.chezString) cu.definitions
 
       -- write the files

src/Compiler/Scheme/Gambit.idr

@@ -307,12 +307,12 @@ useCC : {auto c : Ref Ctxt Defs} ->
         FC -> List String -> List (Name, CFType) -> CFType -> Core (Maybe String, (String, String))
 useCC fc ccs args ret
     = case parseCC ["scheme,gambit", "scheme", "C"] ccs of
-           Nothing => throw (NoForeignCC fc)
+           Nothing => throw (NoForeignCC fc ccs)
            Just ("scheme,gambit", [sfn]) => pure (Nothing, (!(schemeCall fc sfn (map fst args) ret), ""))
            Just ("scheme", [sfn]) => pure (Nothing, (!(schemeCall fc sfn (map fst args) ret), ""))
            Just ("C", [cfn, clib]) => pure (Just clib, !(cCall fc cfn (fnWrapName cfn) clib args ret))
            Just ("C", [cfn, clib, chdr]) => pure (Just clib, !(cCall fc cfn (fnWrapName cfn) clib args ret))
-           _ => throw (NoForeignCC fc)
+           _ => throw (NoForeignCC fc ccs)
   where
     fnWrapName : String -> String -> String
     fnWrapName cfn schemeArgName = schemeArgName ++ "-" ++ cfn ++ "-cFunWrap"

src/Compiler/Scheme/Racket.idr

@@ -267,7 +267,7 @@ useCC : {auto f : Ref Done (List String) } ->
         String -> FC -> List String -> List (Name, CFType) -> CFType -> Core (String, String)
 useCC appdir fc ccs args ret
     = case parseCC ["scheme,racket", "scheme", "C"] ccs of
-           Nothing => throw (NoForeignCC fc)
+           Nothing => throw (NoForeignCC fc ccs)
            Just ("scheme,racket", [sfn]) =>
                do body <- schemeCall fc sfn (map fst args) ret
                   pure ("", body)
@@ -276,7 +276,7 @@ useCC appdir fc ccs args ret
                   pure ("", body)
            Just ("C", [cfn, clib]) => cCall appdir fc cfn clib args ret
            Just ("C", [cfn, clib, chdr]) => cCall appdir fc cfn clib args ret
-           _ => throw (NoForeignCC fc)
+           _ => throw (NoForeignCC fc ccs)
 
 -- For every foreign arg type, return a name, and whether to pass it to the
 -- foreign call (we don't pass '%World')

src/Core/Core.idr

@@ -154,7 +154,8 @@ data Error : Type where
      ForceNeeded : Error
      InternalError : String -> Error
      UserError : String -> Error
-     NoForeignCC : FC -> Error
+     ||| Contains list of specifiers for which foreign call cannot be resolved
+     NoForeignCC : FC -> List String -> Error
      BadMultiline : FC -> String -> Error
 
      InType : FC -> Name -> Error -> Error
@@ -328,8 +329,8 @@ Show Error where
   show ForceNeeded = "Internal error when resolving implicit laziness"
   show (InternalError str) = "INTERNAL ERROR: " ++ str
   show (UserError str) = "Error: " ++ str
-  show (NoForeignCC fc) = show fc ++
-       ":The given specifier was not accepted by any available backend."
+  show (NoForeignCC fc specs) = show fc ++
+       ":The given specifier " ++ show specs ++ " was not accepted by any available backend."
   show (BadMultiline fc str) = "Invalid multiline string: " ++ str
 
   show (InType fc n err)
@@ -420,7 +421,7 @@ getErrorLoc (CyclicImports _) = Nothing
 getErrorLoc ForceNeeded = Nothing
 getErrorLoc (InternalError _) = Nothing
 getErrorLoc (UserError _) = Nothing
-getErrorLoc (NoForeignCC loc) = Just loc
+getErrorLoc (NoForeignCC loc _) = Just loc
 getErrorLoc (BadMultiline loc _) = Just loc
 getErrorLoc (InType _ _ err) = getErrorLoc err
 getErrorLoc (InCon _ _ err) = getErrorLoc err

src/Idris/CommandLine.idr

@@ -358,7 +358,7 @@ envsUsage = makeTextFromOptionsOrEnvs $ map (\e => (e.name, Just e.help)) envs
 
 export
 versionMsg : String
-versionMsg = "Idris 2, version " ++ showVersion True version
+versionMsg = "Idris 2, version " ++ show version
 
 export
 usage : String

src/Idris/Error.idr

@@ -459,9 +459,9 @@ perror (CyclicImports ns)
 perror ForceNeeded = pure $ errorDesc (reflow "Internal error when resolving implicit laziness")
 perror (InternalError str) = pure $ errorDesc (reflow "INTERNAL ERROR" <+> colon) <++> pretty str
 perror (UserError str) = pure $ errorDesc (pretty "Error" <+> colon) <++> pretty str
-perror (NoForeignCC fc) = do
+perror (NoForeignCC fc specs) = do
     let cgs = fst <$> availableCGs (options !(get Ctxt))
-    let res = vsep [ errorDesc (reflow "The given specifier was not accepted by any backend. Available backends" <+> colon)
+    let res = vsep [ errorDesc (reflow ("The given specifier '" ++ show specs ++ "' was not accepted by any backend. Available backends") <+> colon)
                    , indent 2 (concatWith (\ x, y => x <+> ", " <+> y) (map reflow cgs))
                    , reflow "Some backends have additional specifier rules, refer to their documentation."
                    ] <+> line <+> !(ploc fc)