Lazy initialization for recursive bindings · purescript/purescript@814157b · GitHub
Skip to content

Commit 814157b

Browse files
rhendricrhendric
committed
Lazy initialization for recursive bindings
This commit adds src/Language/PureScript/CoreFn/Laziness.hs, a transformation on CoreFn that introduces call-by-need semantics to bindings in recursive binding groups. This is the only way to restore soundness to those groups without forbidding many programs we've previously allowed, as historically any reference to another identifier within the same binding group has been permitted as long as it occurs within a lambda, regardless of whether that lambda is reduced in the course of initialization. The rest of PureScript remains call-by-value. Also, the imperfect prohibitions on cyclic references enforced during desugaring and type checking remain in place; consequently, this change does not alter the set of programs accepted by the compiler. For details, see the extensive commentary in Laziness.hs. This is unlikely to break a working program, but the upshot for users is that it's now possible to get a run-time error when dereferencing an identifier in a recursive binding group before it has been initialized, instead of silently getting an `undefined` value and having that maybe or maybe not lead to an error somewhere else.
1 parent 970bab2 commit 814157b

16 files changed

Lines changed: 1026 additions & 24 deletions

File tree

‎CHANGELOG.d/breaking_fix-4179.md‎

Lines changed: 67 additions & 0 deletions

‎lib/purescript-cst/src/Language/PureScript/Names.hs‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,21 @@ getClassName :: Name -> Maybe (ProperName 'ClassName)
5757
getClassName (TyClassName name) = Just name
5858
getClassName _ = Nothing
5959

60+
-- |
61+
-- This type is meant to be extended with any new uses for idents that come
62+
-- along. Adding constructors to this type is cheaper than adding them to
63+
-- `Ident` because functions that match on `Ident` can ignore all
64+
-- `InternalIdent`s with a single pattern, and thus don't have to change if
65+
-- a new `InternalIdentData` constructor is created.
66+
--
67+
data InternalIdentData
68+
-- Used by CoreFn.Laziness
69+
= RuntimeLazyFactory | Lazy !Text
70+
deriving (Show, Eq, Ord, Generic)
71+
72+
instance NFData InternalIdentData
73+
instance Serialise InternalIdentData
74+
6075
-- |
6176
-- Names for value identifiers
6277
--
@@ -73,6 +88,10 @@ data Ident
7388
-- A generated name used only for type-checking
7489
--
7590
| UnusedIdent
91+
-- |
92+
-- A generated name used only for internal transformations
93+
--
94+
| InternalIdent !InternalIdentData
7695
deriving (Show, Eq, Ord, Generic)
7796

7897
instance NFData Ident
@@ -86,6 +105,7 @@ runIdent (Ident i) = i
86105
runIdent (GenIdent Nothing n) = "$" <> T.pack (show n)
87106
runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n)
88107
runIdent UnusedIdent = unusedIdent
108+
runIdent InternalIdent{} = error "unexpected InternalIdent"
89109

90110
showIdent :: Ident -> Text
91111
showIdent = runIdent
@@ -242,6 +262,7 @@ isQualifiedWith _ _ = False
242262

243263
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)
244264
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
265+
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''InternalIdentData)
245266

246267
instance ToJSON ModuleName where
247268
toJSON (ModuleName name) = toJSON (T.splitOn "." name)

‎purescript.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -151,6 +151,7 @@ common defaults
151151
microlens-platform >=0.4.2 && <0.5,
152152
monad-control >=1.0.3.1 && <1.1,
153153
monad-logger >=0.3.36 && <0.4,
154+
monoidal-containers >=0.6.2.0 && <0.7,
154155
mtl >=2.2.2 && <2.3,
155156
parallel >=3.2.2.0 && <3.3,
156157
parsec >=3.1.14.0 && <3.2,
@@ -198,6 +199,7 @@ library
198199
Language.PureScript.CoreFn.Desugar
199200
Language.PureScript.CoreFn.Expr
200201
Language.PureScript.CoreFn.FromJSON
202+
Language.PureScript.CoreFn.Laziness
201203
Language.PureScript.CoreFn.Meta
202204
Language.PureScript.CoreFn.Module
203205
Language.PureScript.CoreFn.Optimizer

‎src/Language/PureScript/CodeGen/JS.hs‎

Lines changed: 59 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ import Control.Monad (forM, replicateM, void)
1414
import Control.Monad.Except (MonadError, throwError)
1515
import Control.Monad.Reader (MonadReader, asks)
1616
import Control.Monad.Supply.Class
17+
import Control.Monad.Writer (MonadWriter, runWriterT, writer)
1718

1819
import Data.Bifunctor (first)
1920
import Data.List ((\\), intersect)
@@ -22,17 +23,19 @@ import qualified Data.Foldable as F
2223
import qualified Data.Map as M
2324
import qualified Data.Set as S
2425
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
26+
import Data.Monoid (Any(..))
2527
import Data.String (fromString)
2628
import Data.Text (Text)
2729
import qualified Data.Text as T
2830

2931
import Language.PureScript.AST.SourcePos
3032
import Language.PureScript.CodeGen.JS.Common as Common
31-
import Language.PureScript.CoreImp.AST (AST, everywhereTopDownM, withSourceSpan)
33+
import Language.PureScript.CoreImp.AST (AST, everywhere, everywhereTopDownM, withSourceSpan)
3234
import qualified Language.PureScript.CoreImp.AST as AST
3335
import qualified Language.PureScript.CoreImp.Module as AST
3436
import Language.PureScript.CoreImp.Optimizer
3537
import Language.PureScript.CoreFn
38+
import Language.PureScript.CoreFn.Laziness (applyLazinessTransform)
3639
import Language.PureScript.Crash
3740
import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),
3841
MultipleErrors(..), rethrow, errorMessage,
@@ -58,10 +61,10 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude =
5861
let usedNames = concatMap getNames decls
5962
let mnLookup = renameImports usedNames imps
6063
let decls' = renameModules mnLookup decls
61-
jsDecls <- mapM bindToJs decls'
64+
(jsDecls, Any needRuntimeLazy) <- runWriterT $ mapM (moduleBindToJs mn) decls'
6265
let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
6366
let moduleObjectNames = "$foreign" `S.insert` M.keysSet mnReverseLookup
64-
optimized <- traverse (traverse (fmap (annotatePure moduleObjectNames) . optimize)) jsDecls
67+
optimized <- traverse (traverse (fmap (annotatePure moduleObjectNames) . optimize)) (if needRuntimeLazy then [runtimeLazy] : jsDecls else jsDecls)
6568
let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized
6669
`S.union` M.keysSet reExps
6770
let jsImports
@@ -206,6 +209,57 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude =
206209
go (AST.Var _ name) = foldMap S.singleton $ M.lookup name mnReverseLookup
207210
go _ = mempty
208211

212+
-- Check that all integers fall within the valid int range for JavaScript.
213+
checkIntegers :: AST -> m ()
214+
checkIntegers = void . everywhereTopDownM go
215+
where
216+
go :: AST -> m AST
217+
go (AST.Unary _ AST.Negate (AST.NumericLiteral ss (Left i))) =
218+
-- Move the negation inside the literal; since this is a top-down
219+
-- traversal doing this replacement will stop the next case from raising
220+
-- the error when attempting to use -2147483648, as if left unrewritten
221+
-- the value is `Unary Negate (NumericLiteral (Left 2147483648))`, and
222+
-- 2147483648 is larger than the maximum allowed int.
223+
return $ AST.NumericLiteral ss (Left (-i))
224+
go js@(AST.NumericLiteral ss (Left i)) =
225+
let minInt = -2147483648
226+
maxInt = 2147483647
227+
in if i < minInt || i > maxInt
228+
then throwError . maybe errorMessage errorMessage' ss $ IntOutOfRange i "JavaScript" minInt maxInt
229+
else return js
230+
go other = return other
231+
232+
runtimeLazy :: AST
233+
runtimeLazy =
234+
AST.VariableIntroduction Nothing "$runtime_lazy" . Just . AST.Function Nothing Nothing ["name", "moduleName", "init"] . AST.Block Nothing $
235+
[ AST.VariableIntroduction Nothing "state" . Just . AST.NumericLiteral Nothing $ Left 0
236+
, AST.VariableIntroduction Nothing "val" Nothing
237+
, AST.Return Nothing . AST.Function Nothing Nothing ["lineNumber"] . AST.Block Nothing $
238+
[ AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing "state") (AST.NumericLiteral Nothing (Left 2))) (AST.Return Nothing $ AST.Var Nothing "val") Nothing
239+
, AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing "state") (AST.NumericLiteral Nothing (Left 1))) (AST.Throw Nothing $ AST.Unary Nothing AST.New (AST.App Nothing (AST.Var Nothing "ReferenceError") [foldl1 (AST.Binary Nothing AST.Add)
240+
[ AST.Var Nothing "name"
241+
, AST.StringLiteral Nothing " was needed before it finished initializing (module "
242+
, AST.Var Nothing "moduleName"
243+
, AST.StringLiteral Nothing ", line "
244+
, AST.Var Nothing "lineNumber"
245+
, AST.StringLiteral Nothing ")"
246+
], AST.Var Nothing "moduleName", AST.Var Nothing "lineNumber"])) Nothing
247+
, AST.Assignment Nothing (AST.Var Nothing "state") . AST.NumericLiteral Nothing $ Left 1
248+
, AST.Assignment Nothing (AST.Var Nothing "val") $ AST.App Nothing (AST.Var Nothing "init") []
249+
, AST.Assignment Nothing (AST.Var Nothing "state") . AST.NumericLiteral Nothing $ Left 2
250+
, AST.Return Nothing $ AST.Var Nothing "val"
251+
]
252+
]
253+
254+
255+
moduleBindToJs
256+
:: forall m
257+
. (Monad m, MonadReader Options m, MonadSupply m, MonadWriter Any m, MonadError MultipleErrors m)
258+
=> ModuleName
259+
-> Bind Ann
260+
-> m [AST]
261+
moduleBindToJs mn = bindToJs
262+
where
209263
-- |
210264
-- Generate code in the simplified JavaScript intermediate representation for a declaration
211265
--
@@ -215,7 +269,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude =
215269
-- ever applied; it's not possible to use them as values. So it's safe to
216270
-- erase them.
217271
bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
218-
bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
272+
bindToJs (Rec vals) = writer (applyLazinessTransform mn vals) >>= traverse (uncurry . uncurry $ nonRecToJS)
219273

220274
-- | Generate code in the simplified JavaScript intermediate representation for a single non-recursive
221275
-- declaration.
@@ -250,6 +304,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude =
250304
moduleAccessor (Ident prop) = moduleAccessorString prop
251305
moduleAccessor (GenIdent _ _) = internalError "GenIdent in moduleAccessor"
252306
moduleAccessor UnusedIdent = internalError "UnusedIdent in moduleAccessor"
307+
moduleAccessor InternalIdent{} = internalError "InternalIdent in moduleAccessor"
253308

254309
moduleAccessorString :: Text -> AST -> AST
255310
moduleAccessorString = accessorString . mkString . T.replace "'" "$prime"
@@ -486,23 +541,3 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude =
486541
done'' <- go done' (index + 1) bs'
487542
js <- binderToJs elVar done'' binder
488543
return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js)
489-
490-
-- Check that all integers fall within the valid int range for JavaScript.
491-
checkIntegers :: AST -> m ()
492-
checkIntegers = void . everywhereTopDownM go
493-
where
494-
go :: AST -> m AST
495-
go (AST.Unary _ AST.Negate (AST.NumericLiteral ss (Left i))) =
496-
-- Move the negation inside the literal; since this is a top-down
497-
-- traversal doing this replacement will stop the next case from raising
498-
-- the error when attempting to use -2147483648, as if left unrewritten
499-
-- the value is `Unary Negate (NumericLiteral (Left 2147483648))`, and
500-
-- 2147483648 is larger than the maximum allowed int.
501-
return $ AST.NumericLiteral ss (Left (-i))
502-
go js@(AST.NumericLiteral ss (Left i)) =
503-
let minInt = -2147483648
504-
maxInt = 2147483647
505-
in if i < minInt || i > maxInt
506-
then throwError . maybe errorMessage errorMessage' ss $ IntOutOfRange i "JavaScript" minInt maxInt
507-
else return js
508-
go other = return other

‎src/Language/PureScript/CodeGen/JS/Common.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,8 @@ identToJs :: Ident -> Text
2424
identToJs (Ident name) = anyNameToJs name
2525
identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"
2626
identToJs UnusedIdent = unusedIdent
27+
identToJs (InternalIdent RuntimeLazyFactory) = "$runtime_lazy"
28+
identToJs (InternalIdent (Lazy name)) = "$lazy_" <> anyNameToJs name
2729

2830
-- | Convert a 'ProperName' into a valid JavaScript identifier:
2931
--

‎src/Language/PureScript/Constants/Prelude.hs‎

Lines changed: 6 additions & 0 deletions

0 commit comments

Comments
 (0)