diff --git a/libs/contrib/System/Future.idr b/libs/contrib/System/Future.idr index 1fcc8f09354..97f09011362 100644 --- a/libs/contrib/System/Future.idr +++ b/libs/contrib/System/Future.idr @@ -7,14 +7,15 @@ module System.Future export data Future : Type -> Type where [external] -%extern prim__makeFuture : {0 a : Type} -> Lazy a -> Future a +%foreign "scheme:blodwen-make-future" +prim__makeFuture : {0 a : Type} -> (() -> a) -> Future a %foreign "scheme:blodwen-await-future" prim__awaitFuture : {0 a : Type} -> Future a -> a export %inline -- inlining is important for correct context in codegens fork : Lazy a -> Future a -fork = prim__makeFuture +fork l = prim__makeFuture $ \_ => force l export %inline -- inlining is important for correct context in codegens await : Future a -> a diff --git a/src/Compiler/Scheme/Chez.idr b/src/Compiler/Scheme/Chez.idr index 22418c87d4e..c0ca4309953 100644 --- a/src/Compiler/Scheme/Chez.idr +++ b/src/Compiler/Scheme/Chez.idr @@ -170,9 +170,6 @@ mutual = do p' <- schExp cs (chezExtPrim cs) chezString 0 p c' <- schExp cs (chezExtPrim cs) chezString 0 c pure $ mkWorld $ "(blodwen-register-object " ++ p' ++ " " ++ c' ++ ")" - chezExtPrim cs i MakeFuture [_, work] - = do work' <- schExp cs (chezExtPrim cs) chezString 0 $ NmForce EmptyFC LUnknown work - pure $ "(blodwen-make-future (lambda () " ++ work' ++ "))" chezExtPrim cs i prim args = schExtCommon cs (chezExtPrim cs) chezString i prim args diff --git a/src/Compiler/Scheme/Common.idr b/src/Compiler/Scheme/Common.idr index 39d92dad4fa..662ae136d0b 100644 --- a/src/Compiler/Scheme/Common.idr +++ b/src/Compiler/Scheme/Common.idr @@ -207,7 +207,6 @@ data ExtPrim = NewIORef | ReadIORef | WriteIORef | SysOS | SysCodegen | OnCollect | OnCollectAny - | MakeFuture | Unknown Name export @@ -225,7 +224,6 @@ Show ExtPrim where show SysCodegen = "SysCodegen" show OnCollect = "OnCollect" show OnCollectAny = "OnCollectAny" - show MakeFuture = "MakeFuture" show (Unknown n) = "Unknown " ++ show n ||| Match on a user given name to get the scheme primitive @@ -243,8 +241,7 @@ toPrim pn@(NS _ n) (n == UN (Basic "prim__os"), SysOS), (n == UN (Basic "prim__codegen"), SysCodegen), (n == UN (Basic "prim__onCollect"), OnCollect), - (n == UN (Basic "prim__onCollectAny"), OnCollectAny), - (n == UN (Basic "prim__makeFuture"), MakeFuture) + (n == UN (Basic "prim__onCollectAny"), OnCollectAny) ] (Unknown pn) toPrim pn = Unknown pn diff --git a/src/Compiler/Scheme/Racket.idr b/src/Compiler/Scheme/Racket.idr index c7fa06d0fee..d1c86a39f4b 100644 --- a/src/Compiler/Scheme/Racket.idr +++ b/src/Compiler/Scheme/Racket.idr @@ -112,9 +112,6 @@ mutual = do p' <- schExp cs (racketPrim cs) racketString 0 p c' <- schExp cs (racketPrim cs) racketString 0 c pure $ mkWorld $ "(blodwen-register-object " ++ p' ++ " " ++ c' ++ ")" - racketPrim cs i MakeFuture [_, work] - = do work' <- schExp cs (racketPrim cs) racketString 0 $ NmForce EmptyFC LUnknown work - pure $ mkWorld $ "(blodwen-make-future (lambda () " ++ work' ++ "))" racketPrim cs i prim args = schExtCommon cs (racketPrim cs) racketString i prim args diff --git a/support/chez/support.ss b/support/chez/support.ss index cdcb380ace1..b37b5a02709 100644 --- a/support/chez/support.ss +++ b/support/chez/support.ss @@ -454,10 +454,10 @@ ;; Future (define-record future-internal (result ready mutex signal)) -(define (blodwen-make-future work) +(define (blodwen-make-future ty work) (let ([future (make-future-internal #f #f (make-mutex) (make-condition))]) (fork-thread (lambda () - (let ([result (work)]) + (let ([result (work '())]) (with-mutex (future-internal-mutex future) (set-future-internal-result! future result) (set-future-internal-ready! future #t) diff --git a/support/racket/support.rkt b/support/racket/support.rkt index e321c4b65a2..db3b0c23406 100644 --- a/support/racket/support.rkt +++ b/support/racket/support.rkt @@ -468,7 +468,7 @@ ; ) -(define (blodwen-make-future work) (future work)) +(define (blodwen-make-future ty work) (future (lambda () (work '())))) (define (blodwen-await-future ty future) (touch future)) ;; NB: These should *ALWAYS* be used in multi-threaded programs since Racket