From accc596edc15c396c483bafbcb8fae0636354b2b Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Tue, 18 Aug 2026 12:51:23 +0200 Subject: [PATCH 1/9] Add an env-threaded syntax walk to Names The Vars class gives every syntax type a context-free traversal, but an analysis that must know the environment at each reference point cannot be expressed as freeQ: which names are local, what type a receiver has, and whether a type constructor is merely mentioned or actually needed all depend on the enclosing binders. Summ is one structural fold over the typed syntax with those decisions injected through a Walk record. Env hooks advance the environment past statements, declaration groups, parameters, patterns and other binders; result hooks contribute facts at variables, member selections, calls, conditions, iterators, assignment targets and type constructors. The Dot hook owns its receiver, so a client decides how the receiver is walked. plainWalk is inert; a client overrides only the hooks it needs, and env and result are type parameters so Names stays free of any environment type. Vars is unchanged. --- compiler/lib/src/Acton/Names.hs | 251 ++++++++++++++++++++++++++++++++ 1 file changed, 251 insertions(+) diff --git a/compiler/lib/src/Acton/Names.hs b/compiler/lib/src/Acton/Names.hs index d370eb661..4b172f6d5 100644 --- a/compiler/lib/src/Acton/Names.hs +++ b/compiler/lib/src/Acton/Names.hs @@ -427,6 +427,257 @@ instance Vars Pattern where bound (PParen _ p) = bound p bound (PData _ n ixs) = [n] +-- Env-threaded reference walks ---- + +-- A Walk is the hook record for one env-threaded traversal of the typed AST. +-- The structural recursion is written once, in the Summ instances below; a +-- client starts from plainWalk and overrides only the hooks its analysis +-- needs. The env and result types are parameters, so clients thread +-- environments this module knows nothing about. Env hooks advance the +-- environment at binder points; result hooks contribute extra facts at +-- reference points. wDot owns its receiver: the fold does not descend into +-- it, so the hook decides how (and whether) the receiver is walked. + +data Walk env r = Walk { + wSeq :: env -> Stmt -> env, -- past one suite statement + wSuiteEnv :: env -> Suite -> env, -- past a whole suite (try/else) + wDecls :: env -> [Decl] -> env, -- into a mutually recursive group + wDecl :: env -> Decl -> (r, env), -- decl header facts + body env + wLocal :: env -> env, -- into a local scope + wLet :: env -> Suite -> env, -- past a let suite + wPar :: env -> Name -> Maybe Type -> env, + wPat :: env -> Pattern -> env, -- loop/comprehension binder + wItem :: env -> WithItem -> env, + wExcept :: env -> Except -> env, + wQBinds :: env -> QBinds -> env, + wAssignRhs :: env -> [Pattern] -> env, -- into an assignment rhs + wVar :: env -> QName -> r, + wDot :: env -> Expr -> Name -> r, -- owns the receiver + wCall :: env -> Expr -> r, -- extra facts for a callee + wCond :: env -> Expr -> r, -- extra facts for a condition + wIter :: env -> Expr -> r, -- extra facts for an iteratee + wTarg :: env -> Pattern -> r, -- extra facts for a target + wTCon :: env -> QName -> r, -- type constructor reference + wTypeName :: env -> QName -> r } -- type name in a dynamic check + +plainWalk :: Monoid r => Walk env r +plainWalk = Walk { + wSeq = const, + wSuiteEnv = const, + wDecls = const, + wDecl = \env _ -> (mempty, env), + wLocal = id, + wLet = const, + wPar = \env _ _ -> env, + wPat = const, + wItem = const, + wExcept = const, + wQBinds = const, + wAssignRhs = const, + wVar = none, + wDot = \_ _ _ -> mempty, + wCall = none, + wCond = none, + wIter = none, + wTarg = none, + wTCon = none, + wTypeName = none } + where none _ _ = mempty + +class Summ a where + summ :: Monoid r => Walk env r -> env -> a -> r + +summSuite :: Monoid r => Walk env r -> env -> Suite -> r +summSuite w env [] = mempty +summSuite w env (s:ss) = summ w env s <> summSuite w (wSeq w env s) ss + +summWithItems :: Monoid r => Walk env r -> env -> [WithItem] -> (r, env) +summWithItems w env [] = (mempty, env) +summWithItems w env (item:items) = (summ w env item <> more, env') + where (more, env') = summWithItems w (wItem w env item) items + +summPosPar :: Monoid r => Walk env r -> env -> PosPar -> (r, env) +summPosPar w env (PosPar n t e p) = (summ w env t <> summ w env e <> more, env') + where (more, env') = summPosPar w (wPar w env n t) p +summPosPar w env (PosSTAR n t) = (summ w env t, wPar w env n t) +summPosPar w env PosNIL = (mempty, env) + +summKwdPar :: Monoid r => Walk env r -> env -> KwdPar -> (r, env) +summKwdPar w env (KwdPar n t e k) = (summ w env t <> summ w env e <> more, env') + where (more, env') = summKwdPar w (wPar w env n t) k +summKwdPar w env (KwdSTAR n t) = (summ w env t, wPar w env n t) +summKwdPar w env KwdNIL = (mempty, env) + +summComp :: Monoid r => Walk env r -> env -> Comp -> (r, env) +summComp w env (CompFor _ p e c) = (summ w env e <> wIter w env e <> summ w env p <> more, env') + where (more, env') = summComp w (wPat w env p) c +summComp w env (CompIf _ e c) = (summ w env e <> wCond w env e <> more, env') + where (more, env') = summComp w env c +summComp w env NoComp = (mempty, env) + +instance Summ a => Summ [a] where + summ w env = mconcat . map (summ w env) + +instance Summ a => Summ (Maybe a) where + summ w env = maybe mempty (summ w env) + +instance Summ Stmt where + summ w env (Expr _ e) = summ w env e + summ w env (Assign _ ps e) = mconcat [ summ w env p <> wTarg w env p | p <- ps ] <> + summ w (wAssignRhs w env ps) e + summ w env (MutAssign _ t e) = summ w env t <> summ w env e + summ w env (AugAssign _ t _ e) = summ w env t <> summ w env e + summ w env (Assert _ e mbe) = summ w env e <> wCond w env e <> summ w env mbe + summ w env (Pass _) = mempty + summ w env (Delete _ t) = summ w env t + summ w env (Return _ mbe) = summ w env mbe + summ w env (Raise _ e) = summ w env e + summ w env (Break _) = mempty + summ w env (Continue _) = mempty + summ w env (If _ bs els) = summ w env bs <> summSuite w env els + summ w env (While _ e b els) = summ w env e <> wCond w env e <> summSuite w env b <> + summSuite w env els + summ w env (For _ p e b els) = summ w env p <> wTarg w env p <> summ w env e <> wIter w env e <> + summSuite w (wPat w env p) b <> summSuite w env els + summ w env (Try _ b hs els fin) = summSuite w env b <> summ w env hs <> + summSuite w (wSuiteEnv w env b) els <> summSuite w env fin + summ w env (With _ items b) = itemRefs <> summSuite w env' b + where (itemRefs, env') = summWithItems w env items + summ w env (Data _ mbp b) = summ w env mbp <> summSuite w env b + summ w env (VarAssign _ ps e) = mconcat [ summ w env p <> wTarg w env p | p <- ps ] <> summ w env e + summ w env (After _ e e') = summ w env e <> summ w env e' + summ w env (Signature _ _ sc _) = summ w env sc + summ w env (Decl _ ds) = mconcat [ decl d | d <- ds ] + where env' = wDecls w env ds + decl d = hdr <> summSuite w benv (declbody d) + where (hdr, benv) = wDecl w env' d + +instance Summ Branch where + summ w env (Branch e ss) = summ w env e <> wCond w env e <> summSuite w env ss + +instance Summ Handler where + summ w env (Handler ex ss) = summ w env ex <> summSuite w (wExcept w env ex) ss + +instance Summ Except where + summ w env (ExceptAll _) = mempty + summ w env (Except _ qn) = wTypeName w env qn + summ w env (ExceptAs _ qn _) = wTypeName w env qn + +instance Summ WithItem where + summ w env (WithItem e p) = summ w env e <> summ w env p + +instance Summ Expr where + summ w env (Var _ n) = wVar w env n + summ w env (Int _ _ _) = mempty + summ w env (Float _ _ _) = mempty + summ w env (Imaginary _ _ _) = mempty + summ w env (Bool _ _) = mempty + summ w env (None _) = mempty + summ w env (NotImplemented _) = mempty + summ w env (Ellipsis _) = mempty + summ w env (Strings _ _) = mempty + summ w env (BStrings _ _) = mempty + summ w env (Call _ f ps ks) = summ w env f <> summ w env ps <> summ w env ks <> wCall w env f + summ w env (Let _ ss e) = summSuite w env' ss <> summ w (wLet w env' ss) e + where env' = wLocal w env + summ w env (TApp _ f ts) = summ w env f <> summ w env ts + summ w env (Async _ e) = summ w env e + summ w env (Await _ e) = summ w env e + summ w env (Index _ e ix) = summ w env e <> summ w env ix + summ w env (Slice _ e sl) = summ w env e <> summ w env sl + summ w env (Cond _ e1 c e2) = summ w env e1 <> summ w env c <> wCond w env c <> summ w env e2 + summ w env (IsInstance _ e c) = summ w env e <> wTypeName w env c + summ w env (BinOp _ l _ r) = summ w env l <> summ w env r + summ w env (CompOp _ e ops) = summ w env e <> summ w env ops + summ w env (UnOp _ Not e) = summ w env e <> wCond w env e + summ w env (UnOp _ _ e) = summ w env e + summ w env (Dot _ e n) = wDot w env e n + summ w env (Rest _ e _) = summ w env e + summ w env (DotI _ e _) = summ w env e + summ w env (RestI _ e _) = summ w env e + summ w env (Opt _ e _) = summ w env e + summ w env (OptChain _ e) = summ w env e + summ w env (Lambda _ p k e fx) = parRefs <> kwdRefs <> summ w benv e <> summ w env fx + where (parRefs, envP) = summPosPar w (wLocal w env) p + (kwdRefs, benv) = summKwdPar w envP k + summ w env (Yield _ mbe) = summ w env mbe + summ w env (YieldFrom _ e) = summ w env e + summ w env (Tuple _ ps ks) = summ w env ps <> summ w env ks + summ w env (List _ es) = summ w env es + summ w env (ListComp _ e c) = refs <> summ w env' e + where (refs, env') = summComp w (wLocal w env) c + summ w env (Dict _ as) = summ w env as + summ w env (DictComp _ a c) = refs <> summ w env' a + where (refs, env') = summComp w (wLocal w env) c + summ w env (Set _ es) = summ w env es + summ w env (SetComp _ e c) = refs <> summ w env' e + where (refs, env') = summComp w (wLocal w env) c + summ w env (Paren _ e) = summ w env e + summ w env (Box t e) = summ w env t <> summ w env e + summ w env (UnBox t e) = summ w env t <> summ w env e + +instance Summ Elem where + summ w env (Elem e) = summ w env e + summ w env (Star e) = summ w env e + +instance Summ Assoc where + summ w env (Assoc k v) = summ w env k <> summ w env v + summ w env (StarStar e) = summ w env e + +instance Summ OpArg where + summ w env (OpArg _ e) = summ w env e + +instance Summ Sliz where + summ w env (Sliz _ e1 e2 e3) = summ w env e1 <> summ w env e2 <> summ w env e3 + +instance Summ PosArg where + summ w env (PosArg e p) = summ w env e <> summ w env p + summ w env (PosStar e) = summ w env e + summ w env PosNil = mempty + +instance Summ KwdArg where + summ w env (KwdArg _ e k) = summ w env e <> summ w env k + summ w env (KwdStar e) = summ w env e + summ w env KwdNil = mempty + +instance Summ PosPat where + summ w env (PosPat p ps) = summ w env p <> summ w env ps + summ w env (PosPatStar p) = summ w env p + summ w env PosPatNil = mempty + +instance Summ KwdPat where + summ w env (KwdPat _ p ps) = summ w env p <> summ w env ps + summ w env (KwdPatStar p) = summ w env p + summ w env KwdPatNil = mempty + +instance Summ Pattern where + summ w env (PWild _ t) = summ w env t + summ w env (PVar _ _ t) = summ w env t + summ w env (PParen _ p) = summ w env p + summ w env (PTuple _ ps ks) = summ w env ps <> summ w env ks + summ w env (PList _ ps p) = summ w env ps <> summ w env p + summ w env (PData _ n ixs) = wTypeName w env (NoQ n) <> summ w env ixs + +instance Summ TSchema where + summ w env (TSchema _ q t) = summ w env q <> summ w (wQBinds w env q) t + +instance Summ QBind where + summ w env (QBind _ cs) = summ w env cs + +instance Summ TCon where + summ w env (TC qn ts) = wTCon w env qn <> summ w env ts + +instance Summ Type where + summ w env (TCon _ tc) = summ w env tc + summ w env (TFun _ fx p k t) = summ w env fx <> summ w env p <> summ w env k <> summ w env t + summ w env (TTuple _ p k) = summ w env p <> summ w env k + summ w env (TOpt _ t) = summ w env t + summ w env (TRow _ _ _ t r) = summ w env t <> summ w env r + summ w env (TStar _ _ r) = summ w env r + summ w env (TUnboxed _ t) = summ w env t + summ w env _ = mempty + + instance Vars ModuleItem where bound (ModuleItem qn Nothing) = free qn bound (ModuleItem qn (Just n)) = free n From 27c71ac96ee38326c25659d3ec69f698281e92b3 Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Tue, 18 Aug 2026 12:52:09 +0200 Subject: [PATCH 2/9] Share actor state classification with Deactorizer Deactorizer decides which actor initializer bindings become instance state: parameters and initializer names that the actor's methods use, all of them when the body is unfinished, and hidden names only when they are state variables or method free variables. Move that decision next to envOf as QuickType.actorBindings, returning both the promoted bindings and the initializer names that stay local, so other consumers of the actor layout share Deactorizer's rule instead of restating it. envOf now covers Protocol and Extension declarations with an empty environment. Both are translated away during inference, so a post-inference caller that walks a typed suite containing them no longer hits a missing pattern. --- compiler/lib/src/Acton/Deactorizer.hs | 5 +---- compiler/lib/src/Acton/QuickType.hs | 23 +++++++++++++++++++++++ 2 files changed, 24 insertions(+), 4 deletions(-) diff --git a/compiler/lib/src/Acton/Deactorizer.hs b/compiler/lib/src/Acton/Deactorizer.hs index 30b5aec2b..db5c58d17 100644 --- a/compiler/lib/src/Acton/Deactorizer.hs +++ b/compiler/lib/src/Acton/Deactorizer.hs @@ -141,10 +141,7 @@ instance Deact Decl where (decls,ss) = partition isDecl body inits = filter (not . isSig) ss stvars = statevars body - fvs = free decls - live_vars - | hasNotImpl body = bound params ++ dom (envOf inits) - | otherwise = bound params `intersect` fvs ++ [ n | n <- dom $ envOf inits, not (isHidden n) || n `elem` (stvars++fvs) ] + (live_vars,_) = actorBindings params KwdNIL body locals = nub $ live_vars ++ bound decls wrapped = bound wrapdefs wrapdefs = [ d | Decl _ ds <- decls, d@Def{dname=n, dfx=fx} <- ds, fx == fxProc || fx == fxAction ] diff --git a/compiler/lib/src/Acton/QuickType.hs b/compiler/lib/src/Acton/QuickType.hs index 2396acfde..6cad08e07 100644 --- a/compiler/lib/src/Acton/QuickType.hs +++ b/compiler/lib/src/Acton/QuickType.hs @@ -450,6 +450,29 @@ instance EnvOf Decl where wrap (n, NDef sc dec doc) = (n, NDef (wrapFX sc) dec doc) wrap (n, i) = (n, i) wrapFX (TSchema l q t) = TSchema l q (if effect t == fxProc then t{ effect = fxAction } else t) + envOf Protocol{} = [] + envOf Extension{} = [] + +-- Actor lowering promotes exactly these initializer bindings to state. Keep +-- the classification beside envOf, which supplies the inferred initializer +-- names, so row construction and reachability consume the same decision as +-- Deactorizer instead of reproducing its liveness rules. +actorBindings :: PosPar -> KwdPar -> Suite -> ([Name],[Name]) +actorBindings p k body = (live,deferred) + where (decls,statements) = partition isDecl body + inits = filter (not . isSig) statements + params = bound (p,k) + initNames = dom (envOf inits) + usedByActor = statevars body ++ free decls + live + | hasNotImpl body = uniqueNames (params ++ initNames) + | otherwise = uniqueNames $ + params `intersect` free decls ++ + [ n | n <- initNames + , not (isHidden n) || n `elem` usedByActor ] + deferred = [ n | n <- uniqueNames (assigned inits) + , n `notElem` live ] + dropDefSelf (n, NDef (TSchema l q t) dec doc) = (n, NDef (TSchema l q (dropSelf t dec)) dec doc) From 819863cca10ea17b66514756ec023d6c94dfd657 Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Tue, 18 Aug 2026 13:04:56 +0200 Subject: [PATCH 3/9] Define exact typed interface rows Split a type-checked module into rows that a later build can load independently: one row per top-level statement, and for each class, actor, protocol and extension a container skeleton plus one row per method, per attribute declaration and per attribute initializer group. The skeleton keeps the original statement order and marks each hole with the member row that fills it, so restoring all rows reproduces the module exactly and restoring a subset yields a partial declaration whose remaining members are known. Attribute initialization is split by the type checker's own rule. Its scan of the constructor already decides which self attributes are initialized before self can escape; scanInitPrefix now also reports how many leading statements that prefix covers, and row partitioning uses that count as the boundary between per-attribute initializer fragments and the rest of the constructor. Actor bodies use the same actor state classification as Deactorizer, so an initializer that Deactorizer would promote to state is stored under that attribute. The interface format version changes because rows written without this structure cannot be loaded. --- compiler/lib/package.yaml.in | 2 + compiler/lib/src/Acton/Builtin.hs | 6 + compiler/lib/src/Acton/InterfaceRows.hs | 432 ++++++++++++++++++++++++ compiler/lib/src/Acton/QuickType.hs | 19 +- compiler/lib/src/Acton/Syntax.hs | 4 +- compiler/lib/src/Acton/Types.hs | 12 +- 6 files changed, 469 insertions(+), 6 deletions(-) create mode 100644 compiler/lib/src/Acton/InterfaceRows.hs diff --git a/compiler/lib/package.yaml.in b/compiler/lib/package.yaml.in index a4832b245..76025dec9 100644 --- a/compiler/lib/package.yaml.in +++ b/compiler/lib/package.yaml.in @@ -73,6 +73,7 @@ library: - Acton.Completion - Acton.Compile - Acton.CommandLineParser + - Acton.Converter - Acton.Deactorizer - Acton.Diagnostics - Acton.DocPrinter @@ -80,6 +81,7 @@ library: - Acton.Fingerprint - Acton.Hashing - Acton.HttpFetch + - Acton.InterfaceRows - Acton.Kinds - Acton.LambdaLifter - Acton.NameInfo diff --git a/compiler/lib/src/Acton/Builtin.hs b/compiler/lib/src/Acton/Builtin.hs index 5c52287fe..0a298d7b8 100644 --- a/compiler/lib/src/Acton/Builtin.hs +++ b/compiler/lib/src/Acton/Builtin.hs @@ -130,6 +130,9 @@ nRef = name "Ref" nMsg = name "Msg" nBaseException = name "BaseException" nException = name "Exception" +nNotImplementedError = name "NotImplementedError" +nSerialize = name "serialize" +nDeserialize = name "deserialize" nStopIteration = name "StopIteration" nValueError = name "ValueError" --- @@ -198,6 +201,9 @@ qnRef = gBuiltin nRef qnMsg = gBuiltin nMsg qnBaseException = gBuiltin nBaseException qnException = gBuiltin nException +qnNotImplementedError = gBuiltin nNotImplementedError +qnSerialize = gBuiltin nSerialize +qnDeserialize = gBuiltin nDeserialize qnStopIteration = gBuiltin nStopIteration qnValueError = gBuiltin nValueError --- diff --git a/compiler/lib/src/Acton/InterfaceRows.hs b/compiler/lib/src/Acton/InterfaceRows.hs new file mode 100644 index 000000000..4c70f15d0 --- /dev/null +++ b/compiler/lib/src/Acton/InterfaceRows.hs @@ -0,0 +1,432 @@ +-- SPDX-License-Identifier: BSD-3-Clause + +{-# LANGUAGE DeriveGeneric #-} + +-- | Independently loadable typed syntax. +-- +-- A container row is an ordinary Acton syntax skeleton: it keeps the +-- container and method headers, but replaces independently selectable +-- statements with numbered holes. Method bodies, attribute declarations and +-- initializer statements live in member rows. Reconstruction is therefore a +-- small syntax-tree traversal which fills selected holes and turns unselected +-- methods into ABI-preserving stubs. +-- +-- This module defines and reconstructs the syntax rows. +-- 'Acton.Reachability' partitions typed syntax, records what each row uses, +-- and selects the rows needed by a build; 'InterfaceFiles' stores and reads +-- them by exact key. +module Acton.InterfaceRows where + +import Control.DeepSeq +import Control.Monad +import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as M +import qualified Data.Persist as Persist +import qualified Data.Set as S +import GHC.Generics + +import qualified Acton.Builtin as B +import qualified Acton.Names as Names +import qualified Acton.Syntax as A +import Utils + + +-- Stored syntax ------------------------------------------------------------------------------- + +data MemberKey + = Method A.Name + | Attr A.Name + | StaticInit A.Name + | InstanceInit A.Name + | InitRest + deriving (Show, Eq, Ord, Generic) + +instance Persist.Persist MemberKey +instance NFData MemberKey + +data ContainerHead + = ActorHead SrcLoc A.Name A.QBinds A.PosPar A.KwdPar (Maybe String) + | ClassHead SrcLoc A.Name A.QBinds [A.TCon] (Maybe String) + | ProtocolHead SrcLoc A.Name A.QBinds [A.PCon] (Maybe String) + | ExtensionHead SrcLoc A.QBinds A.TCon [A.PCon] (Maybe String) + deriving (Show, Eq, Generic) + +instance Persist.Persist ContainerHead +instance NFData ContainerHead + +data MethodSlot = MethodSlot + { slotName :: A.Name + , slotOrdinal :: Int + , slotIsConstructor :: Bool + , slotHeader :: A.Decl + } deriving (Show, Eq, Generic) + +instance Persist.Persist MethodSlot +instance NFData MethodSlot + +data ShapeDecl + = InlineDecl A.Decl + | MethodDecl MethodSlot + deriving (Show, Eq, Generic) + +instance Persist.Persist ShapeDecl +instance NFData ShapeDecl + +data ShapeStmt + = InlineStmt A.Stmt + | HoleStmt Int + | DeclStmt SrcLoc [ShapeDecl] + | IfStmt SrcLoc [(A.Expr, SuiteShape)] SuiteShape + deriving (Show, Eq, Generic) + +instance Persist.Persist ShapeStmt +instance NFData ShapeStmt + +newtype SuiteShape = SuiteShape { suiteShape :: [ShapeStmt] } + deriving (Show, Eq, Generic) + +instance Persist.Persist SuiteShape +instance NFData SuiteShape + +data ContainerShape = ContainerShape + { shapeName :: A.Name + , shapeHead :: ContainerHead + , shapeSuite :: SuiteShape + } deriving (Show, Eq, Generic) + +instance Persist.Persist ContainerShape +instance NFData ContainerShape + +-- | A numbered statement removed from either the container suite or the +-- declarative prefix of a class constructor. +data Fragment + = SuiteFragment Int A.Stmt + | ConstructorFragment Int A.Stmt + deriving (Show, Eq, Generic) + +instance Persist.Persist Fragment +instance NFData Fragment + +data MemberContent + = MethodContent [A.Decl] + | AttrContent [Fragment] + | InitializerContent [Fragment] + | InitRestContent + { restConstructor :: Maybe A.Decl + , restInitializers :: [Fragment] + } + deriving (Show, Eq, Generic) + +instance Persist.Persist MemberContent +instance NFData MemberContent + +data StoredStmt + = StoredWhole [A.Name] A.Stmt + | StoredDecls SrcLoc [StoredDecl] + deriving (Show, Eq, Generic) + +instance Persist.Persist StoredStmt +instance NFData StoredStmt + +data StoredDecl + = StoredInline A.Decl + | StoredContainer A.Name + deriving (Show, Eq, Generic) + +instance Persist.Persist StoredDecl +instance NFData StoredDecl + +storedStmtNames :: StoredStmt -> [A.Name] +storedStmtNames (StoredWhole owners _) = owners +storedStmtNames (StoredDecls _ decls) = map storedDeclName decls + where + storedDeclName (StoredInline decl) = Names.dname' decl + storedDeclName (StoredContainer name) = name + +data InterfaceRows = InterfaceRows + { rowModuleName :: A.ModName + , rowImports :: [A.Import] + , rowDoc :: Maybe String + , rowHasNotImpl :: Bool + , rowStatements :: [StoredStmt] + , rowShapes :: M.Map A.Name ContainerShape + , rowMembers :: M.Map A.Name (M.Map MemberKey MemberContent) + } deriving (Show, Eq, Generic) + +instance NFData InterfaceRows + +newtype RowError = RowError String deriving (Show, Eq) + +type RowResult = Either RowError + +rowError :: String -> RowResult a +rowError = Left . RowError + + +-- Reconstruction ------------------------------------------------------------------------------- + +data RestoreMode = RestoreExact | RestoreSelected deriving Eq + +data LoadedMembers = LoadedMembers + { loadedMethods :: M.Map (A.Name, Int) A.Decl + , loadedConstructor :: Maybe A.Decl + , loadedStatements :: M.Map Int A.Stmt + , loadedInitBody :: M.Map Int A.Stmt + , loadedPrunableInit :: IntSet.IntSet + } + +emptyLoadedMembers :: LoadedMembers +emptyLoadedMembers = LoadedMembers M.empty Nothing M.empty M.empty IntSet.empty + +restoreInterfaceRows :: InterfaceRows -> RowResult A.Module +restoreInterfaceRows rows = do + stmts <- mapM (restoreStoredStmt rows) (rowStatements rows) + return (A.Module (rowModuleName rows) (rowImports rows) (rowDoc rows) stmts) + +restoreStoredStmt :: InterfaceRows -> StoredStmt -> RowResult A.Stmt +restoreStoredStmt _ (StoredWhole _ stmt) = return stmt +restoreStoredStmt rows (StoredDecls l decls) = A.Decl l <$> mapM restore decls + where + restore (StoredInline decl) = return decl + restore (StoredContainer name) = do + shape <- required ("missing container shape " ++ A.rawstr name) (M.lookup name $ rowShapes rows) + members <- required ("missing member rows " ++ A.rawstr name) (M.lookup name $ rowMembers rows) + restoreExactContainer shape members + +restoreExactContainer :: ContainerShape -> M.Map MemberKey MemberContent -> RowResult A.Decl +restoreExactContainer shape members = + restoreContainer RestoreExact shape members (M.keysSet members) + +restoreSelectedContainer :: ContainerShape + -> M.Map MemberKey MemberContent + -> S.Set MemberKey + -> RowResult A.Decl +restoreSelectedContainer = restoreContainer RestoreSelected + +restoreContainer :: RestoreMode + -> ContainerShape + -> M.Map MemberKey MemberContent + -> S.Set MemberKey + -> RowResult A.Decl +restoreContainer mode shape members selected = do + loaded0 <- foldM loadMember emptyLoadedMembers (S.toAscList selected) + loaded <- case mode of + RestoreExact -> return loaded0 + RestoreSelected -> pruneSelectedInitializers shape instanceInitializers loaded0 + suite <- restoreSuite mode (shapeSuite shape) loaded + return (restoreHead (shapeHead shape) suite) + where + loadMember loaded key = case (key, M.lookup key members) of + (Method name, Just (MethodContent decls)) -> + foldM (insertMethod name) loaded (zip [0..] decls) + (Attr _, Just (AttrContent declarations)) -> + loadAttr mode selectedAttrs declarations loaded + (StaticInit _, Just (InitializerContent fragments)) -> + foldM (loadFragment $ const False) loaded fragments + (InstanceInit _, Just (InitializerContent fragments)) -> + foldM (loadFragment isConstructorFragment) loaded fragments + (InitRest, Just content@InitRestContent{}) -> loadRest content loaded + (_, Just _) -> rowError ("member kind mismatch for " ++ memberLabel key) + (_, Nothing) -> rowError ("missing member row " ++ memberLabel key) + selectedAttrs = S.fromList [ name | Attr name <- S.toAscList selected ] + instanceInitializers = S.fromList [ name | InstanceInit name <- S.toAscList selected ] + isConstructorFragment ConstructorFragment{} = True + isConstructorFragment _ = False + +insertMethod :: A.Name -> LoadedMembers -> (Int, A.Decl) -> RowResult LoadedMembers +insertMethod name loaded (ordinal, decl) + | A.dname decl /= name = rowError ("method row/name mismatch for " ++ A.rawstr name) + | M.member (name, ordinal) (loadedMethods loaded) = + rowError ("duplicate method occurrence " ++ A.rawstr name) + | otherwise = return loaded + { loadedMethods = M.insert (name, ordinal) decl (loadedMethods loaded) } + +loadAttr :: RestoreMode + -> S.Set A.Name + -> [Fragment] + -> LoadedMembers + -> RowResult LoadedMembers +loadAttr mode selected declarations loaded = + foldM (loadFragment $ const False) loaded (map narrow declarations) + where + narrow fragment + | mode == RestoreSelected = narrowProperty selected fragment + | otherwise = fragment + +narrowProperty :: S.Set A.Name -> Fragment -> Fragment +narrowProperty selected (SuiteFragment hole (A.Signature l names schema A.Property)) = + SuiteFragment hole (A.Signature l (filter (`S.member` selected) names) schema A.Property) +narrowProperty _ fragment = fragment + +loadRest :: MemberContent -> LoadedMembers -> RowResult LoadedMembers +loadRest content loaded = do + constructor <- case (loadedConstructor loaded, restConstructor content) of + (Nothing, new) -> return new + (Just old, Just new) + | old == new -> return (Just old) + | otherwise -> rowError "conflicting constructor rows" + (old, Nothing) -> return old + foldM (loadFragment (const False)) loaded{loadedConstructor=constructor} + (restInitializers content) + +loadFragment :: (Fragment -> Bool) -> LoadedMembers -> Fragment -> RowResult LoadedMembers +loadFragment prunable loaded fragment = case fragment of + SuiteFragment hole stmt -> do + statements <- insertSame hole stmt (loadedStatements loaded) + ("conflicting suite fragment " ++ show hole) + return loaded { loadedStatements = statements } + ConstructorFragment index stmt -> do + body <- insertSame index stmt (loadedInitBody loaded) + ("conflicting constructor fragment " ++ show index) + return loaded + { loadedInitBody = body + , loadedPrunableInit = if prunable fragment + then IntSet.insert index (loadedPrunableInit loaded) + else loadedPrunableInit loaded + } + +pruneSelectedInitializers :: ContainerShape + -> S.Set A.Name + -> LoadedMembers + -> RowResult LoadedMembers +pruneSelectedInitializers shape active loaded + | IntSet.null (loadedPrunableInit loaded) = return loaded + | otherwise = do + self <- case [ name + | slot <- methodSlots (shapeSuite shape) + , slotIsConstructor slot + , Just name <- [A.selfPar (slotHeader slot)] + ] of + [name] -> return name + _ -> rowError "prunable constructor initializers have no unique self parameter" + return loaded + { loadedInitBody = M.mapMaybeWithKey (project self) (loadedInitBody loaded) } + where + project self index stmt + | IntSet.member index (loadedPrunableInit loaded) = pruneConstructorInit self active stmt + | otherwise = Just stmt + +restoreSuite :: RestoreMode -> SuiteShape -> LoadedMembers -> RowResult A.Suite +restoreSuite mode (SuiteShape shape) loaded = fmap concat $ mapM restore shape + where + restore (InlineStmt stmt) = return [stmt] + restore (HoleStmt hole) = case M.lookup hole (loadedStatements loaded) of + Just stmt -> return [stmt] + Nothing + | mode == RestoreExact -> rowError ("missing suite fragment " ++ show hole) + | otherwise -> return [] + restore (DeclStmt l decls) = (:[]) . A.Decl l <$> mapM restoreDecl decls + restore (IfStmt l branches elseShape) = do + branches' <- mapM restoreBranch branches + elseSuite <- restoreSuite mode elseShape loaded + if mode == RestoreSelected && all (null . branchBody) branches' && null elseSuite + then return [] + else return [A.If l branches' elseSuite] + restoreDecl (InlineDecl decl) = return decl + restoreDecl (MethodDecl slot) + | slotIsConstructor slot = restoreConstructor slot + | otherwise = restoreMethod slot + restoreMethod slot = case M.lookup (slotName slot, slotOrdinal slot) (loadedMethods loaded) of + Just decl -> return decl + Nothing + | mode == RestoreExact -> rowError ("missing method body " ++ A.rawstr (slotName slot)) + | otherwise -> return (raisingStub $ slotHeader slot) + restoreConstructor slot = case loadedConstructor loaded of + Just decl -> return decl { A.dbody = map snd (M.toAscList $ loadedInitBody loaded) } + Nothing + | mode == RestoreExact -> rowError "missing constructor row" + | otherwise -> return (raisingStub $ slotHeader slot) + restoreBranch (condition, body) = A.Branch condition <$> restoreSuite mode body loaded + branchBody (A.Branch _ body) = body + +methodSlots :: SuiteShape -> [MethodSlot] +methodSlots (SuiteShape stmts) = concatMap inStmt stmts + where + inStmt (DeclStmt _ decls) = [ slot | MethodDecl slot <- decls ] + inStmt (IfStmt _ branches elseShape) = + concatMap (methodSlots . snd) branches ++ methodSlots elseShape + inStmt _ = [] + +methodHeader :: A.Decl -> A.Decl +methodHeader decl@A.Def{} = decl + { A.pos = stripDefaultsP (A.pos decl) + , A.kwd = stripDefaultsK (A.kwd decl) + , A.dbody = [] + , A.ddoc = Nothing + } +methodHeader decl = error ("methodHeader: " ++ show decl) + +stripDefaultsP :: A.PosPar -> A.PosPar +stripDefaultsP (A.PosPar n typ _ rest) = A.PosPar n typ Nothing (stripDefaultsP rest) +stripDefaultsP p@A.PosSTAR{} = p +stripDefaultsP A.PosNIL = A.PosNIL + +stripDefaultsK :: A.KwdPar -> A.KwdPar +stripDefaultsK (A.KwdPar n typ _ rest) = A.KwdPar n typ Nothing (stripDefaultsK rest) +stripDefaultsK p@A.KwdSTAR{} = p +stripDefaultsK A.KwdNIL = A.KwdNIL + +raisingStub :: A.Decl -> A.Decl +raisingStub decl@A.Def{} = decl + { A.dbody = [A.sRaise $ A.eCall (A.eQVar B.qnNotImplementedError) + [A.Strings NoLoc ["unselected method"]]] } +raisingStub decl = error ("raisingStub: " ++ show decl) + +restoreHead :: ContainerHead -> A.Suite -> A.Decl +restoreHead (ActorHead l n q p k doc) suite = A.Actor l n q p k suite doc +restoreHead (ClassHead l n q bases doc) suite = A.Class l n q bases suite doc +restoreHead (ProtocolHead l n q bases doc) suite = A.Protocol l n q bases suite doc +restoreHead (ExtensionHead l q con bases doc) suite = A.Extension l q con bases suite doc + +pruneConstructorInit :: A.Name -> S.Set A.Name -> A.Stmt -> Maybe A.Stmt +pruneConstructorInit self active stmt = case stmt of + A.MutAssign _ target _ + | Just name <- selfTarget self target + , S.notMember name active -> Nothing + A.AugAssign _ target _ _ + | Just name <- selfTarget self target + , S.notMember name active -> Nothing + A.If l branches elseSuite -> Just $ A.If l + [ A.Branch condition (pruneSuite body) | A.Branch condition body <- branches ] + (pruneSuite elseSuite) + A.While l condition body elseSuite -> + Just $ A.While l condition (pruneSuite body) (pruneSuite elseSuite) + A.For l pattern source body elseSuite -> + Just $ A.For l pattern source (pruneSuite body) (pruneSuite elseSuite) + A.Try l body handlers elseSuite finallySuite -> Just $ A.Try l + (pruneSuite body) + [ A.Handler exception (pruneSuite handlerBody) + | A.Handler exception handlerBody <- handlers + ] + (pruneSuite elseSuite) + (pruneSuite finallySuite) + A.With l items body -> Just $ A.With l items (pruneSuite body) + A.Data l pattern body -> Just $ A.Data l pattern (pruneSuite body) + _ -> Just stmt + where + pruneSuite suite = + [ projected + | nested <- suite + , Just projected <- [pruneConstructorInit self active nested] + ] + +selfTarget :: A.Name -> A.Target -> Maybe A.Name +selfTarget self (A.Dot _ (A.Var _ (A.NoQ receiver)) name) + | receiver == self = Just name +selfTarget _ _ = Nothing + +insertSame :: (Ord k, Eq a) => k -> a -> M.Map k a -> String -> RowResult (M.Map k a) +insertSame key value values msg = case M.lookup key values of + Nothing -> return (M.insert key value values) + Just old | old == value -> return values + Just _ -> rowError msg + +required :: String -> Maybe a -> RowResult a +required msg = maybe (rowError msg) return + +memberLabel :: MemberKey -> String +memberLabel (Method name) = "method " ++ A.rawstr name +memberLabel (Attr name) = "attribute " ++ A.rawstr name +memberLabel (StaticInit name) = "static initializer " ++ A.rawstr name +memberLabel (InstanceInit name) = "instance initializer " ++ A.rawstr name +memberLabel InitRest = "constructor rest" diff --git a/compiler/lib/src/Acton/QuickType.hs b/compiler/lib/src/Acton/QuickType.hs index 6cad08e07..aa3a35a56 100644 --- a/compiler/lib/src/Acton/QuickType.hs +++ b/compiler/lib/src/Acton/QuickType.hs @@ -453,6 +453,24 @@ instance EnvOf Decl where envOf Protocol{} = [] envOf Extension{} = [] +-- Protocols and extensions are translated during inference, so making them +-- part of the general EnvOf instance changes the scopes seen by Types. Row +-- reconstruction needs their selected member environments explicitly, after +-- inference, and calls this narrower operation for that purpose. +envOfDecl :: Decl -> TEnv +envOfDecl (Protocol _ n q as ss doc) + = [(n, NProto q (leftpath as) (map dropDefSelf $ envOf ss) doc)] +envOfDecl (Extension _ q c ps ss doc) + = [(extensionName ps c, NExt q c (leftpath ps) + (map dropDefSelf $ envOf ss) [] doc)] +envOfDecl decl = envOf decl + +envOfTopSuite :: Suite -> TEnv +envOfTopSuite = concatMap envOfTopStmt + where + envOfTopStmt (Decl _ decls) = concatMap envOfDecl decls + envOfTopStmt stmt = envOf stmt + -- Actor lowering promotes exactly these initializer bindings to state. Keep -- the classification beside envOf, which supplies the inferred initializer -- names, so row construction and reachability consume the same decision as @@ -473,7 +491,6 @@ actorBindings p k body = (live,deferred) deferred = [ n | n <- uniqueNames (assigned inits) , n `notElem` live ] - dropDefSelf (n, NDef (TSchema l q t) dec doc) = (n, NDef (TSchema l q (dropSelf t dec)) dec doc) dropDefSelf (n, i) = (n, i) diff --git a/compiler/lib/src/Acton/Syntax.hs b/compiler/lib/src/Acton/Syntax.hs index 1d64146e6..bb3a3f8ed 100644 --- a/compiler/lib/src/Acton/Syntax.hs +++ b/compiler/lib/src/Acton/Syntax.hs @@ -26,7 +26,7 @@ import Control.DeepSeq import Prelude hiding((<>)) version :: [Int] -version = [0,34] +version = [0,36] data Module = Module { modname::ModName, imps::[Import], mdoc::Maybe String, mbody::Suite } deriving (Eq,Show,Generic,NFData) @@ -170,7 +170,7 @@ modPath (ModName ns) = map nstr ns modCat (ModName ns) n = ModName (ns++[n]) instance Ord ModName where - compare a b = compare (modPath a) (modPath b) + compare (ModName as) (ModName bs) = compare as bs instance Data.Hashable.Hashable ModName where hashWithSalt s (ModName ns) = Data.Hashable.hashWithSalt s ns diff --git a/compiler/lib/src/Acton/Types.hs b/compiler/lib/src/Acton/Types.hs index d86879823..f0b632b27 100644 --- a/compiler/lib/src/Acton/Types.hs +++ b/compiler/lib/src/Acton/Types.hs @@ -12,7 +12,7 @@ -- {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} -module Acton.Types(reconstruct, showTyFile, prettySigs, TypeError(..), TypeErrors(..), TypeProgressCallback, TypeInferredCallback) where +module Acton.Types(reconstruct, scanInitPrefix, showTyFile, prettySigs, TypeError(..), TypeErrors(..), TypeProgressCallback, TypeInferredCallback) where import Control.Concurrent.Async import Control.Concurrent.Chan @@ -1352,9 +1352,15 @@ stripTypeApps f = f -- attributes since we cannot statically determine if the loop executes. The -- loop is scanned to ensure `self` does not escape. scanSelfAssigns :: Env -> Name -> Suite -> Suite -> [Name] -scanSelfAssigns env self classBody stmts = attrs +scanSelfAssigns env self classBody stmts = fst (scanInitPrefix env self classBody stmts) + +-- | The attributes initialized by the declarative prefix of __init__ and the +-- number of leading statements that prefix covers. Row partitioning splits +-- the prefix by attribute and keeps the rest of the constructor whole. +scanInitPrefix :: EnvF x -> Name -> Suite -> Suite -> ([Name], Int) +scanInitPrefix env self classBody stmts = (attrs, count) where - (attrs, _, _) = scanSuite [] stmts + (attrs, count, _) = scanSuite [] stmts continue assigns crossesBoundary seen rest | crossesBoundary = (assigns, 0, True) From 956d2cf2a3ee551f0259e26180c40e18310bbaa4 Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Tue, 18 Aug 2026 13:05:04 +0200 Subject: [PATCH 4/9] Persist exact reachability rows Walk each type-checked module once with its type environment and record what every stored row depends on: which top-level names it needs, which class members it selects, which classes it constructs, and which types it only mentions in a signature. Names inside a class body resolve against that class, so a bare method call from another method becomes a member edge rather than a global one. Selection of a member on an expression is classified from the receiver: a class-valued receiver gives a static edge, an instance receiver a dispatch edge, and a receiver whose type is an alias is resolved through the alias first. Conditions and iterated expressions record the __bool__, __iter__ and __next__ methods that the Normalizer will introduce later, since those calls do not exist in the typed tree yet. The walk is Names.summ with a hook record; this module keeps only the classification. Rows are stored alongside the syntax rows: a summary per top-level name, per member and per initializer group, the effective provider of each method and attribute slot for a class after inheritance and extensions, the constructor kind, the reflectable attributes, and one aggregate summary for consumers that must materialize a whole module. Every row is written as its own key with a stored copy of that key, so a reader validates what it loaded; the reader and writer for all row kinds are one keyed-row engine parameterized by a small descriptor per kind. Missing or impossible targets are compiler errors. Selection never falls back to keeping everything. Hashing gains a module-owned component for statements not owned by any name and a codegen identity derived from the compiler executable, so a selective output is keyed by the compiler that produced it. CodeGen emits opaque struct forward declarations for classes a projected module only references, and leaves witness fields out of class tables so a class's C layout does not depend on which witnesses were materialized. --- compiler/acton/test/parse/simple.all.golden | 2 +- compiler/acton/test/parse/simple.cgen.golden | 2 +- compiler/acton/test/parse/simple.hgen.golden | 2 +- compiler/lib/bench/CompilerBench.hs | 34 +- compiler/lib/package.yaml.in | 2 + compiler/lib/src/Acton/CodeGen.hs | 28 +- compiler/lib/src/Acton/Hashing.hs | 281 +- compiler/lib/src/Acton/Reachability.hs | 2586 +++++++++++++++++ compiler/lib/src/Acton/ReachabilityRows.hs | 185 ++ compiler/lib/src/Acton/Testing.hs | 3 +- compiler/lib/src/InterfaceFiles.hs | 1519 ++++++++-- compiler/lib/test/9-codegen/boxparam.c | 2 +- compiler/lib/test/9-codegen/boxparam.h | 2 +- compiler/lib/test/9-codegen/chunking.c | 2 +- compiler/lib/test/9-codegen/chunking.h | 2 +- compiler/lib/test/9-codegen/deact.c | 2 +- compiler/lib/test/9-codegen/deact.h | 2 +- compiler/lib/test/9-codegen/ints.c | 2 +- compiler/lib/test/9-codegen/ints.h | 2 +- compiler/lib/test/9-codegen/lines.c | 2 +- compiler/lib/test/9-codegen/lines.h | 2 +- compiler/lib/test/9-codegen/witness_forward.c | 2 +- compiler/lib/test/9-codegen/witness_forward.h | 2 +- 23 files changed, 4349 insertions(+), 319 deletions(-) create mode 100644 compiler/lib/src/Acton/Reachability.hs create mode 100644 compiler/lib/src/Acton/ReachabilityRows.hs diff --git a/compiler/acton/test/parse/simple.all.golden b/compiler/acton/test/parse/simple.all.golden index 8c91cf9f3..ba27056aa 100644 --- a/compiler/acton/test/parse/simple.all.golden +++ b/compiler/acton/test/parse/simple.all.golden @@ -66,7 +66,7 @@ pure def main () -> None: return None =============================================== -/* Acton impl hash: d08c9793c890e917cbf7dfbd7d8d83d565b77536de5215cba908ef7093e36f72 */ +/* Acton codegen hash: test-hash */ #pragma once #include "builtin/builtin.h" #include "rts/rts.h" diff --git a/compiler/acton/test/parse/simple.cgen.golden b/compiler/acton/test/parse/simple.cgen.golden index 0b500bf6b..c28bd88bc 100644 --- a/compiler/acton/test/parse/simple.cgen.golden +++ b/compiler/acton/test/parse/simple.cgen.golden @@ -1,4 +1,4 @@ -/* Acton impl hash: d08c9793c890e917cbf7dfbd7d8d83d565b77536de5215cba908ef7093e36f72 */ +/* Acton codegen hash: test-hash */ #include "rts/common.h" #include "out/types/simple.h" B_NoneType simpleQ_main () { diff --git a/compiler/acton/test/parse/simple.hgen.golden b/compiler/acton/test/parse/simple.hgen.golden index 0aeeb173e..3a7f6c435 100644 --- a/compiler/acton/test/parse/simple.hgen.golden +++ b/compiler/acton/test/parse/simple.hgen.golden @@ -1,4 +1,4 @@ -/* Acton impl hash: d08c9793c890e917cbf7dfbd7d8d83d565b77536de5215cba908ef7093e36f72 */ +/* Acton codegen hash: test-hash */ #pragma once #include "builtin/builtin.h" #include "rts/rts.h" diff --git a/compiler/lib/bench/CompilerBench.hs b/compiler/lib/bench/CompilerBench.hs index fc1eb3c79..8979a8862 100644 --- a/compiler/lib/bench/CompilerBench.hs +++ b/compiler/lib/bench/CompilerBench.hs @@ -234,14 +234,17 @@ prepareHashBench typesPath sourcePath = do E.evaluate (length tests) let NameInfo.NModule _ fullIface _ = nmod - srcItems = Hashing.topLevelItems parsed - implItems = Hashing.topLevelItems tchecked + owners = Hashing.typedTopLevelOwners tchecked + srcItems = Hashing.sourceTopLevelItems parsed + implItems = Hashing.topLevelItems owners tchecked nameKeys = Set.fromList (map topLevelItemName srcItems ++ map topLevelItemName implItems) nameInfoMap = Map.fromList fullIface hashEnv = Env.setMod modName env (_, pubSigExtDeps) = Hashing.pubSigSplitDepsFromNameInfoMap modName hashEnv nameKeys nameInfoMap (_, implExtDeps) = Hashing.implSplitDepsFromItems modName hashEnv nameKeys implItems - extMods = Set.toList (Hashing.externalModules pubSigExtDeps `Set.union` Hashing.externalModules implExtDeps) + extMods = Set.toList + (Hashing.externalModules (concat $ Map.elems pubSigExtDeps) `Set.union` + Hashing.externalModules (concat $ Map.elems implExtDeps)) extMaps <- fmap Map.fromList $ mapM (\mn -> do m <- resolveNameHashMap paths mn @@ -296,7 +299,7 @@ hashBenchFromHashes mn env nmod extMaps implItems nameSrcHashes nameImplHashes s pubExtHashes implExtHashes modulePubHash = Hashing.modulePubHashFromIface nmod nameHashes - moduleImplHash = Hashing.moduleImplHashFromNameHashes nameHashes + moduleImplHash = Hashing.moduleImplHashFromNameHashes InterfaceFiles.emptyModuleHashInfo nameHashes in (modulePubHash, moduleImplHash, nameHashes) hashBenchOnce :: Syntax.ModName @@ -308,9 +311,10 @@ hashBenchOnce :: Syntax.ModName -> (B.ByteString, B.ByteString, [InterfaceFiles.NameHashInfo]) hashBenchOnce mn env parsed tchecked nmod extMaps = let NameInfo.NModule _ fullIface _ = nmod - srcItems = Hashing.topLevelItems parsed + owners = Hashing.typedTopLevelOwners tchecked + srcItems = Hashing.sourceTopLevelItems parsed nameSrcHashes = Hashing.nameHashesFromItems srcItems - implItems = Hashing.topLevelItems tchecked + implItems = Hashing.topLevelItems owners tchecked nameImplHashes = Hashing.nameHashesFromItems implItems nameInfoMap = Map.fromList fullIface selfPubHashes = Hashing.nameInfoHashes nameInfoMap @@ -353,8 +357,9 @@ runHashBreakdown reps typesPath sourcePath = do nmod = hbsNMod bench NameInfo.NModule _ fullIface _ = nmod nameInfoMap = Map.fromList fullIface - srcItems = Hashing.topLevelItems parsed - implItems = Hashing.topLevelItems tchecked + owners = Hashing.typedTopLevelOwners tchecked + srcItems = Hashing.sourceTopLevelItems parsed + implItems = Hashing.topLevelItems owners tchecked E.evaluate (length srcItems) E.evaluate (length implItems) @@ -368,12 +373,12 @@ runHashBreakdown reps typesPath sourcePath = do _ <- measureRepeated statsEnabled "hash_extract_src_items" reps $ do parsed' <- readIORef parsedRef - let items = Hashing.topLevelItems parsed' + let items = Hashing.sourceTopLevelItems parsed' E.evaluate (length items) _ <- measureRepeated statsEnabled "hash_extract_impl_items" reps $ do tchecked' <- readIORef tcheckedRef - let items = Hashing.topLevelItems tchecked' + let items = Hashing.topLevelItems owners tchecked' E.evaluate (length items) _ <- measureRepeated statsEnabled "hash_ast_src" reps $ do @@ -634,7 +639,7 @@ runHashBreakdown reps typesPath sourcePath = do _ <- measureRepeated statsEnabled "hash_finish_module_hashes" reps $ do nameHashes' <- readIORef nameHashesRef let modulePubHash = Hashing.modulePubHashFromIface nmod nameHashes' - moduleImplHash = Hashing.moduleImplHashFromNameHashes nameHashes' + moduleImplHash = Hashing.moduleImplHashFromNameHashes InterfaceFiles.emptyModuleHashInfo nameHashes' E.evaluate (rnf (modulePubHash, moduleImplHash)) return (B.length modulePubHash + B.length moduleImplHash) @@ -642,7 +647,7 @@ runHashBreakdown reps typesPath sourcePath = do nameKeys' <- readIORef nameKeysRef pubHashes' <- readIORef pubHashesRef implHashes' <- readIORef implHashesRef - let moduleHashes = Hashing.moduleHashesFromHashMaps nmod nameKeys' pubHashes' implHashes' + let moduleHashes = Hashing.moduleHashesFromHashMaps nmod InterfaceFiles.emptyModuleHashInfo nameKeys' pubHashes' implHashes' E.evaluate (rnf moduleHashes) return (B.length (fst moduleHashes) + B.length (snd moduleHashes)) @@ -769,6 +774,7 @@ runCompilerFront buildFront runBack typesPath sourcePath = do benchGopts opts False + False paths env0 parsed @@ -800,7 +806,9 @@ runCompilerFront buildFront runBack typesPath sourcePath = do (do s3 <- getStats statsEnabled t3 <- getCurrentTime - (_mtime, mtiming) <- Compile.runBackPasses benchGopts (Compile.bjOpts job) (Compile.bjPaths job) (Compile.bjInput job) (return True) + (_mtime, mtiming) <- Compile.runBackPasses + benchGopts (Compile.bjOpts job) (Compile.bjPaths job) (Compile.bjInput job) + (\action -> action >> return True) (\_ -> return ()) t4 <- getCurrentTime s4 <- getStats statsEnabled elapsed "back" t3 t4 diff --git a/compiler/lib/package.yaml.in b/compiler/lib/package.yaml.in index 76025dec9..e82e86d03 100644 --- a/compiler/lib/package.yaml.in +++ b/compiler/lib/package.yaml.in @@ -90,6 +90,8 @@ library: - Acton.Parser - Acton.Printer - Acton.QuickType + - Acton.Reachability + - Acton.ReachabilityRows - Acton.Solver - Acton.SourceProvider - Acton.Syntax diff --git a/compiler/lib/src/Acton/CodeGen.hs b/compiler/lib/src/Acton/CodeGen.hs index 58a27be6b..a2ffcf731 100644 --- a/compiler/lib/src/Acton/CodeGen.hs +++ b/compiler/lib/src/Acton/CodeGen.hs @@ -37,14 +37,14 @@ import Numeric -- For fast SrcLoc offset->line lookup when emitting #line import qualified Data.IntMap.Strict as IM -generate :: Acton.Env.Env0 -> FilePath -> String -> Bool -> Module -> String -> IO (String,String,String) -generate env srcbase srcText emitLines m hash = do return (n, h, c) +generate :: Acton.Env.Env0 -> [Name] -> FilePath -> String -> Bool -> Module -> String -> IO (String,String,String) +generate env declarations srcbase srcText emitLines m@(Module mn _ _ _) hash = do return (n, h, c) where n = concat (Data.List.intersperse "." (modPath (modname m))) --render $ quotes $ gen env0 (modname m) - hashComment = text "/* Acton impl hash:" <+> text hash <+> text "*/" - h = render $ hashComment $+$ hModule env0 m + hashComment = text "/* Acton codegen hash:" <+> text hash <+> text "*/" + h = render $ hashComment $+$ hModule env0 declarations m c = render $ hashComment $+$ cModule env0 srcbase srcText emitLines m - env0 = genEnv $ setMod (modname m) env + env0 = genEnv $ setMod mn env genRoot :: Acton.Env.Env0 -> QName -> IO String genRoot env0 qn@(GName m n) = do return $ render (cInclude $+$ cIncludeMods $+$ cInit $+$ cRoot) @@ -220,16 +220,23 @@ storageType env t = rawType env t -- Header ------------------------------------------------------------------------------------------- -hModule env (Module m imps _ stmts) = text "#pragma" <+> text "once" $+$ +hModule env declarations (Module m imps _ stmts) + = text "#pragma" <+> text "once" $+$ (if inBuiltin env then empty else text "#include \"builtin/builtin.h\"" $+$ -- TODO: can we include out/types/__builtin__.h instead? include env "rts" (modName ["rts"])) $+$ vcat (map (include env "out/types") $ modNames imps) $+$ + vcat (map (compactDeclaration env) declarationOnly) $+$ hSuite 1 env1 stmts $+$ hSuite 2 env1 stmts $+$ text "void" <+> genTopName env initKW <+> parens empty <> semi where env1 = classdefine stmts env + classNames = [ n | (n,NClass{}) <- envOf stmts ] + declarationOnly = uniqueNames [ n | n <- declarations, n `notElem` classNames ] + +compactDeclaration env n = text "struct" <+> genTopName env n <> semi $+$ + text "typedef" <+> text "struct" <+> genTopName env n <+> char '*' <> genTopName env n <> semi hSuite phase env [] = empty @@ -306,7 +313,9 @@ fields env c = map field (vsubst [(tvSelf,tCon c)] te) field (n, NDef sc Static _) = funsig2 env (Just n) (B.rtypeOf env c n) <> semi field (n, NDef sc NoDec _) = methsig2 env c (Just n) (B.rtypeOf env c n) <> semi - field (n, NVar t) = varsig env n t <> semi + field (n, NVar t) + | isWitness n = empty + | otherwise = varsig env n t <> semi field (n, NSig sc Static _) = funsig2 env (Just n) (B.rtypeOf env c n) <> semi field (n, NSig sc NoDec _) = methsig2 env c (Just n) (B.rtypeOf env c n) <> semi field (n, NSig sc Property _) @@ -672,7 +681,7 @@ initGlobalDoc env s = genStmt1 env s $+$ initClassBase env c q as hasCDef = methodtable env c <> dot <> gen env gcinfoKW <+> equals <+> doubleQuotes (genTopName env c) <> semi $+$ methodtable env c <> dot <> gen env superclassKW <+> equals <+> super <> semi $+$ - vcat [ inherit c' n | (c',n) <- inheritedAttrs env (NoQ c) ] + vcat [ inherit c' n | (c',n) <- inheritedAttrs env (NoQ c), not (isWitness n) ] where tc = TC (NoQ c) [ tVar v | QBind v _ <- q ] super = if null as then text "NULL" else parens (gen env qnSuperClass) <> text "&" <> methodtable' env (tcname $ head as) inherit c' n @@ -692,7 +701,8 @@ initClass env c q (Signature{} : ss) b = initClass env c q ss b initClass env c q (s : ss) b | isNotImpl s = initClass env c q ss b | otherwise = genStmt1 env s $+$ - vcat [ genTopName env c <> dot <> gen env n <+> equals <+> gen env n <> semi | (n,_) <- te ] $+$ + vcat [ genTopName env c <> dot <> gen env n <+> equals <+> gen env n <> semi + | (n,_) <- te, not (isWitness n) ] $+$ initClass env1 c q ss b where te = excludeDefined env (envOf s) env1 = ldefine te env diff --git a/compiler/lib/src/Acton/Hashing.hs b/compiler/lib/src/Acton/Hashing.hs index a419f162f..2401537ca 100644 --- a/compiler/lib/src/Acton/Hashing.hs +++ b/compiler/lib/src/Acton/Hashing.hs @@ -1,15 +1,24 @@ module Acton.Hashing ( TopLevelItem(..) , topLevelItems + , sourceTopLevelItems + , typedTopLevelOwners , NameHashInputs(..) -- Production hashing pipeline , prepareNameHashInputs , assembleNameHashes , mergePubDeps + , publicImplDeps , refreshImplHashes , moduleHashesFromHashMaps , modulePubHashFromIface , moduleImplHashFromNameHashes + , codegenIdentity + , wholeCodegenHash + , moduleOwnImplHash + , moduleImplSplitDeps + , finishModuleHash + , moduleProjectionHash -- Benchmarks and tests use these to compare individual stages. , nameHashesFromItems , pubSigDepsFromNameInfoMap @@ -35,6 +44,7 @@ import qualified Acton.Env as Env import qualified Acton.NameInfo as I import qualified Acton.Names as Names import Acton.Prim (mPrim) +import qualified Acton.QuickType as QuickType import qualified Acton.Syntax as A import qualified InterfaceFiles import Utils (chunksOf) @@ -50,7 +60,7 @@ import qualified Data.HashSet as HashSet import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef') import Control.Concurrent.Async (mapConcurrently) import GHC.Conc (getNumCapabilities) -import Data.List (foldl', intercalate, nub) +import Data.List (foldl', intercalate) import qualified Data.List import qualified Data.Map as M import Data.Maybe (mapMaybe) @@ -61,6 +71,7 @@ import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (peek, peekByteOff, poke, pokeByteOff) import GHC.Float (castDoubleToWord64) import System.IO.Unsafe (unsafePerformIO) +import System.Environment (getExecutablePath) data TopLevelItem = TLDecl A.Name A.Decl | TLStmt A.Name A.Stmt @@ -78,11 +89,12 @@ data NameHashInputs = NameHashInputs , nhiImplExtDeps :: M.Map A.Name [A.QName] } --- | Render a local name as a stable string key. +-- | Render a local name for diagnostics. Semantic ordering and hashing use +-- the constructor-tagged Name directly. nameKey :: A.Name -> String nameKey = A.nstr --- | Render a qualified name as a stable string key. +-- | Render a qualified name for diagnostics. qnameKey :: A.QName -> String qnameKey qn = case qn of A.GName m n -> modNameToString m ++ "." ++ A.nstr n @@ -93,21 +105,44 @@ qnameKey qn = case qn of modNameToString :: A.ModName -> String modNameToString m = intercalate "." (A.modPath m) --- | Extract hashable top-level items from a module. -topLevelItems :: A.Module -> [TopLevelItem] -topLevelItems (A.Module _ _ _ suite) = concatMap items suite +-- | Source trees precede the transformations performed by Kinds and Types, +-- so their top-level statement positions cannot be paired with the typed +-- tree. Hash the bindings visible directly in the source syntax; typed items +-- independently supply the authoritative post-front ownership domain. +sourceTopLevelItems :: A.Module -> [TopLevelItem] +sourceTopLevelItems (A.Module _ _ _ suite) = concatMap items suite where items stmt = case stmt of - A.Decl _ ds -> - [ TLDecl (Names.dname' d) d | d <- ds ] - A.Signature _ ns _ _ -> - [ TLStmt n stmt | n <- ns ] - A.Assign _ ps _ -> - [ TLStmt n stmt | n <- nub (Names.bound ps) ] - A.VarAssign _ ps _ -> - [ TLStmt n stmt | n <- nub (Names.bound ps) ] + A.Decl _ decls -> [ TLDecl (Names.dname' decl) decl | decl <- decls ] + A.Signature _ names _ _ -> [ TLStmt name stmt | name <- names ] + A.Assign _ patterns _ -> + [ TLStmt name stmt | name <- Env.uniqueNames (Names.bound patterns) ] + A.VarAssign _ patterns _ -> + [ TLStmt name stmt | name <- Env.uniqueNames (Names.bound patterns) ] _ -> [] +-- | Partition a module with the exact owners established from its typed +-- interface rows. Source and typed fragments must share the same top-level +-- statement structure; disagreement is an internal compiler error rather +-- than a reason to widen ownership. +topLevelItems :: [[A.Name]] -> A.Module -> [TopLevelItem] +topLevelItems owners (A.Module _ _ _ suite) + | length owners /= length suite = + error "topLevelItems: statement count mismatch" + | otherwise = concat (zipWith items owners suite) + where + items expected stmt = case stmt of + A.Decl _ decls + | length expected == length decls -> zipWith TLDecl expected decls + | otherwise -> error "topLevelItems: declaration count mismatch" + _ -> [ TLStmt name stmt | name <- expected ] + +typedTopLevelOwners :: A.Module -> [[A.Name]] +typedTopLevelOwners (A.Module _ _ _ suite) = map owners suite + where + owners (A.Decl _ decls) = map Names.dname' decls + owners stmt = Env.uniqueNames (map fst (QuickType.envOf stmt)) + -- The feed-operation format is versioned: small buffered writes, bulk hash -- bytes, and little-endian words are distinct operations by design. Changing -- this format must come with a .tydb version bump so old interface hashes are @@ -772,7 +807,7 @@ hashCycleGroupFromWith sink selfHashes lookupLocal locals externals = hashCycleMemberWith :: HashSink -> B.ByteString -> B.ByteString -> A.Name -> IO B.ByteString hashCycleMemberWith sink self groupHash n = hashFeedWith sink $ \sink' -> - feedTag 254 sink' >> feedTag 2 sink' >> feedHashBytes self sink' >> feedHashBytes groupHash sink' >> feedString (nameKey n) sink' + feedTag 254 sink' >> feedTag 2 sink' >> feedHashBytes self sink' >> feedHashBytes groupHash sink' >> feedName n sink' hashNameHashEntries :: Int -> [(String, B.ByteString)] -> B.ByteString hashNameHashEntries tag entries = @@ -792,7 +827,7 @@ hashNameHashEntriesWith tag entries feedEntry = hashNameHashMapEntriesForNames :: Int -> M.Map A.Name B.ByteString -> [A.Name] -> B.ByteString hashNameHashMapEntriesForNames tag hashes names = hashNameHashEntriesWith tag names $ \n sink -> - feedString (nameKey n) sink >> feedHashBytes (M.findWithDefault B.empty n hashes) sink + feedName n sink >> feedHashBytes (M.findWithDefault B.empty n hashes) sink pubSigDepsFromNameInfoMap :: M.Map A.Name I.NameInfo -> M.Map A.Name [A.QName] pubSigDepsFromNameInfoMap nameInfoMap = @@ -846,6 +881,9 @@ isDerivedQName qn = case qn of A.QName _ n -> isDerivedName n A.NoQ n -> isDerivedName n +publicImplDeps :: [A.QName] -> [A.QName] +publicImplDeps = filter (not . isDerivedQName) + -- | Public hashes include signature deps plus implementation deps, but derived -- implementation names are internal and should not require public hashes. mergePubDeps :: M.Map A.Name [A.Name] @@ -1070,6 +1108,8 @@ unionDepSplit (ls, es) (ls', es') = (HashSet.union ls ls', HashSet.union es es') insertQNameDep :: A.ModName -> Env.Env0 -> Data.Set.Set A.Name -> NameSet -> A.QName -> DepSplit -> DepSplit +insertQNameDep _ _ _ _ (A.NoQ n) acc + | n == Names.selfKW' = acc insertQNameDep mn env localNames bound qn@(A.NoQ n) acc | Data.Set.member n bound = acc | otherwise = addSplitDepHash mn env localNames acc qn @@ -1112,8 +1152,16 @@ implSplitDepsFromItemsWithProgress onProgress mn env localNames items = do implItemSplitDeps :: A.ModName -> Env.Env0 -> Data.Set.Set A.Name -> TopLevelItem -> (A.Name, DepSplit) implItemSplitDeps mn env localNames item = case item of - TLDecl name decl -> (name, splitDeclDirect Data.Set.empty decl emptyDepSplitDirect) - TLStmt name stmt -> (name, splitStmtDirect Data.Set.empty stmt emptyDepSplitDirect) + TLDecl name decl -> (name, implFragmentSplitDeps mn env localNames (ImplDecl decl)) + TLStmt name stmt -> (name, implFragmentSplitDeps mn env localNames (ImplStmt stmt)) + +data ImplFragment = ImplDecl A.Decl | ImplStmt A.Stmt + +implFragmentSplitDeps :: A.ModName -> Env.Env0 -> Data.Set.Set A.Name -> ImplFragment -> DepSplit +implFragmentSplitDeps mn env localNames fragment = + case fragment of + ImplDecl decl -> splitDeclDirect Data.Set.empty decl emptyDepSplitDirect + ImplStmt stmt -> splitStmtDirect Data.Set.empty stmt emptyDepSplitDirect where splitQName = insertQNameDep mn env localNames @@ -1320,6 +1368,23 @@ implItemSplitDeps mn env localNames item = A.TFX{} -> acc A.TUnboxed _ ty -> splitTypeDirect bound ty acc +-- | Dependencies of statements emitted as mandatory module initialization, +-- using the same scope-aware walker as name-owned implementation fragments. +moduleImplSplitDeps :: A.ModName + -> Env.Env0 + -> Data.Set.Set A.Name + -> [A.Stmt] + -> ([A.Name], [A.QName]) +moduleImplSplitDeps mn env localNames statements = + ( Data.List.sort (HashSet.toList locals) + , Data.List.sort (HashSet.toList externals) + ) + where + (locals, externals) = foldl' unionDepSplit emptyDepSplitDirect + [ implFragmentSplitDeps mn env localNames (ImplStmt stmt) + | stmt <- statements + ] + -- | Split deps into locals and external qualified names for hashing. splitDeps :: A.ModName -> Env.Env0 @@ -1382,10 +1447,10 @@ finishHashSplitDeps pairs = , M.map (Data.List.sort . HashSet.toList . snd) pairs ) --- | Collect referenced external modules from dependency lists. -externalModules :: M.Map A.Name [A.QName] -> Data.Set.Set A.ModName +-- | Collect referenced external modules from dependency names. +externalModules :: [A.QName] -> Data.Set.Set A.ModName externalModules deps = - Data.Set.fromList $ mapMaybe modOf (concat (M.elems deps)) + Data.Set.fromList $ mapMaybe modOf deps where modOf qn = case qn of A.GName m _ -> Just m @@ -1476,7 +1541,7 @@ computeHashesSortedDeps selfHashes localDeps extDeps = pure (M.insert n finalHash acc) CyclicSCC ns -> let nsSet = Data.Set.fromList ns - selfHashesSorted = [ selfHashes M.! n | n <- Data.List.sortOn nameKey ns ] + selfHashesSorted = [ selfHashes M.! n | n <- Data.List.sort ns ] outsideDeps = Data.Set.toList $ Data.Set.fromList [ d | n <- ns, d <- M.findWithDefault [] n localDeps, Data.Set.notMember d nsSet ] externalDeps = Data.Set.toList $ Data.Set.fromList (concat [ M.findWithDefault [] n extDeps | n <- ns ]) @@ -1569,8 +1634,8 @@ assembleNameHashes :: Data.Set.Set A.Name -> M.Map A.Name [(A.QName, B.ByteString)] -> [InterfaceFiles.NameHashInfo] assembleNameHashes nameKeys nameSrcHashes pubHashes implHashes ownImplHashes pubLocalDeps implLocalDeps pubExtHashes implExtHashes = - let namesSorted = Data.List.sortOn nameKey (Data.Set.toList nameKeys) - localDeps m n = Data.List.sortOn nameKey (M.findWithDefault [] n m) + let namesSorted = Data.List.sort (Data.Set.toList nameKeys) + localDeps m n = Data.List.sort (M.findWithDefault [] n m) in [ InterfaceFiles.NameHashInfo { InterfaceFiles.nhName = n @@ -1622,7 +1687,7 @@ refreshImplHashes nameHashes nameImplHashes implLocalDeps implExtHashes = -- and its pub/impl deps must keep their places in the regenerated rows. [ if M.member n nameImplHashes then nh { InterfaceFiles.nhImplHash = M.findWithDefault B.empty n implHashes - , InterfaceFiles.nhImplLocalDeps = Data.List.sortOn nameKey (M.findWithDefault [] n implLocalDeps) + , InterfaceFiles.nhImplLocalDeps = Data.List.sort (M.findWithDefault [] n implLocalDeps) , InterfaceFiles.nhImplDeps = M.findWithDefault [] n implExtHashes } else nh @@ -1630,14 +1695,59 @@ refreshImplHashes nameHashes nameImplHashes implLocalDeps implExtHashes = , let n = InterfaceFiles.nhName nh ] +-- | Structural implementation hash for the ordered imports and ownerless +-- statements emitted by module initialization. +moduleOwnImplHash :: [A.ModName] -> [A.Stmt] -> B.ByteString +moduleOwnImplHash imports statements = + hashFeed $ \sink -> do + feedTag 254 sink + feedTag 7 sink + feedList feedModName imports sink + feedList feedTLStmt statements sink + +-- | Finish the module-owned implementation component after name hashes and +-- external dependency hashes have been resolved. +finishModuleHash :: M.Map A.Name B.ByteString + -> B.ByteString + -> [[A.Name]] + -> [A.Name] + -> [(A.QName, B.ByteString)] + -> [(A.QName, B.ByteString)] + -> InterfaceFiles.ModuleHashInfo +finishModuleHash implHashes ownHash statementOwners localDeps pubDeps implDeps + | null missing = InterfaceFiles.ModuleHashInfo + { InterfaceFiles.mhOwnImplHash = ownHash + , InterfaceFiles.mhStatementOwners = statementOwners + , InterfaceFiles.mhImplHash = componentHash + , InterfaceFiles.mhImplLocalDeps = locals + , InterfaceFiles.mhPubDeps = pubs + , InterfaceFiles.mhImplDeps = impls + } + | otherwise = error ("finishModuleHash: missing local implementation hashes for " ++ + Data.List.intercalate ", " (map A.nstr missing)) + where + locals = Data.List.sort localDeps + pubs = Data.List.sortOn fst pubDeps + impls = Data.List.sortOn fst implDeps + missing = filter (`M.notMember` implHashes) locals + componentHash = hashFeed $ \sink -> do + feedTag 254 sink + feedTag 8 sink + feedHashBytes ownHash sink + feedList (feedList feedName) statementOwners sink + feedResolvedDepHashes (`M.lookup` implHashes) locals impls sink + -- | Hash module-level pub/impl summaries from the final per-name hash maps. moduleHashesFromHashMaps :: I.NModule + -> InterfaceFiles.ModuleHashInfo -> Data.Set.Set A.Name -> M.Map A.Name B.ByteString -> M.Map A.Name B.ByteString -> (B.ByteString, B.ByteString) -moduleHashesFromHashMaps nmod nameKeys pubHashes implHashes = - (modulePubHashFromHashMap nmod pubHashes, moduleImplHashFromHashMap nameKeys implHashes) +moduleHashesFromHashMaps nmod moduleHashInfo nameKeys pubHashes implHashes = + ( modulePubHashFromHashMap nmod pubHashes + , moduleImplHashFromHashMap moduleHashInfo nameKeys implHashes + ) -- | Hash the module public interface entries. modulePubHashFromIface :: I.NModule -> [InterfaceFiles.NameHashInfo] -> B.ByteString @@ -1652,19 +1762,114 @@ modulePubHashFromHashMap :: I.NModule -> M.Map A.Name B.ByteString -> B.ByteStri modulePubHashFromHashMap nmod pubHashes = let I.NModule _ iface _ = nmod pubNamesSorted = - Data.List.sortOn nameKey [ n | (n, _) <- iface, Names.isPublicName n ] + Data.List.sort [ n | (n, _) <- iface, Names.isPublicName n ] in hashNameHashMapEntriesForNames 3 pubHashes pubNamesSorted -- | Hash the module impl entries from per-name impl hashes. -moduleImplHashFromNameHashes :: [InterfaceFiles.NameHashInfo] -> B.ByteString -moduleImplHashFromNameHashes infos = - hashNameHashEntriesWith 4 infosSorted $ \nh sink -> - feedString (nameKey (InterfaceFiles.nhName nh)) sink >> - feedHashBytes (InterfaceFiles.nhImplHash nh) sink +moduleImplHashFromNameHashes :: InterfaceFiles.ModuleHashInfo + -> [InterfaceFiles.NameHashInfo] + -> B.ByteString +moduleImplHashFromNameHashes moduleHashInfo infos = + hashModuleImplEntries (InterfaceFiles.mhImplHash moduleHashInfo) infosSorted $ \nh sink -> + feedName (InterfaceFiles.nhName nh) sink >> feedHashBytes (InterfaceFiles.nhImplHash nh) sink where - infosSorted = Data.List.sortOn (nameKey . InterfaceFiles.nhName) infos + infosSorted = Data.List.sortOn InterfaceFiles.nhName infos + +-- | Identity of the compiler binary performing the back passes. Interface +-- compatibility controls typed-cache reuse; generated C/H must additionally +-- change whenever the actual Normalizer-to-CodeGen implementation changes. +-- Long-lived compiler entry points force this value at process startup, before +-- an on-disk executable can be replaced underneath the running image. +codegenIdentity :: B.ByteString +codegenIdentity = unsafePerformIO $ do + executable <- getExecutablePath + SHA256.hash <$> B.readFile executable +{-# NOINLINE codegenIdentity #-} + +-- | Whole-module output includes source-derived line directives in addition +-- to semantic implementation. Keep those mappings and the line-emission mode +-- in the generated-code key without making raw source bytes invalidate +-- selective projections. +wholeCodegenHash :: Bool -> B.ByteString -> B.ByteString -> B.ByteString +wholeCodegenHash emitLines implHash sourceHash = + hashFeed $ \sink -> do + feedTag 254 sink + feedTag 9 sink + feedHashBytes codegenIdentity sink + feedList feedInt A.version sink + feedBool emitLines sink + feedHashBytes implHash sink + feedHashBytes sourceHash sink + +hashModuleImplEntries :: B.ByteString -> [a] -> (a -> HashFeed) -> B.ByteString +hashModuleImplEntries moduleHash entries feedEntry = + hashFeed $ \sink -> do + feedTag 254 sink + feedTag 4 sink + feedTag 6 sink + feedHashBytes moduleHash sink + feedTag 4 sink + mapM_ (\entry -> feedEntry entry sink) entries + feedTag 5 sink -moduleImplHashFromHashMap :: Data.Set.Set A.Name -> M.Map A.Name B.ByteString -> B.ByteString -moduleImplHashFromHashMap nameKeys implHashes = - let namesSorted = Data.List.sortOn nameKey (Data.Set.toList nameKeys) - in hashNameHashMapEntriesForNames 4 implHashes namesSorted +-- | Hash the exact typed module and type environment consumed by the back +-- passes. Source locations, docstrings and comments are deliberately absent +-- from the structural feed. Canonical module/import identities, every +-- materialized statement and the projected container ABI/layout all +-- participate. +moduleProjectionHash :: A.Module -> I.TEnv -> B.ByteString +moduleProjectionHash module0 te = hashFeed $ \sink -> do + feedTag 200 sink + feedModName (A.modname m) sink + feedList feedModName (A.importsOf m) sink + feedSuite (A.mbody m) sink + feedTag 201 sink + feedTEnv te sink + where m = stripProjectionDocs module0 + +-- Documentation is retained in .tydb for tooling, but it is not consumed by +-- any back pass and therefore must not invalidate generated code. Nested +-- declarations in ordinary suites are stripped along with top-level ones. +stripProjectionDocs :: A.Module -> A.Module +stripProjectionDocs (A.Module mn imps _ suite) = + A.Module mn imps Nothing (map stripStmtDocs suite) + +stripStmtDocs :: A.Stmt -> A.Stmt +stripStmtDocs stmt = case stmt of + A.If l branches els -> A.If l (map stripBranchDocs branches) (map stripStmtDocs els) + A.While l e body els -> A.While l e (map stripStmtDocs body) (map stripStmtDocs els) + A.For l p e body els -> A.For l p e (map stripStmtDocs body) (map stripStmtDocs els) + A.Try l body handlers els fin -> + A.Try l (map stripStmtDocs body) (map stripHandlerDocs handlers) + (map stripStmtDocs els) (map stripStmtDocs fin) + A.With l items body -> A.With l items (map stripStmtDocs body) + A.Data l pattern body -> A.Data l pattern (map stripStmtDocs body) + A.Decl l decls -> A.Decl l (map stripDeclDocs decls) + _ -> stmt + +stripBranchDocs :: A.Branch -> A.Branch +stripBranchDocs (A.Branch e body) = A.Branch e (map stripStmtDocs body) + +stripHandlerDocs :: A.Handler -> A.Handler +stripHandlerDocs (A.Handler ex body) = A.Handler ex (map stripStmtDocs body) + +stripDeclDocs :: A.Decl -> A.Decl +stripDeclDocs decl = case decl of + A.Def l n q p k result body dec fx _ -> + A.Def l n q p k result (map stripStmtDocs body) dec fx Nothing + A.Actor l n q p k body _ -> + A.Actor l n q p k (map stripStmtDocs body) Nothing + A.Class l n q bases body _ -> + A.Class l n q bases (map stripStmtDocs body) Nothing + A.Protocol l n q bases body _ -> + A.Protocol l n q bases (map stripStmtDocs body) Nothing + A.Extension l q target bases body _ -> + A.Extension l q target bases (map stripStmtDocs body) Nothing + A.Typedef l n q typ _ -> + A.Typedef l n q typ Nothing + +moduleImplHashFromHashMap :: InterfaceFiles.ModuleHashInfo -> Data.Set.Set A.Name -> M.Map A.Name B.ByteString -> B.ByteString +moduleImplHashFromHashMap moduleHashInfo nameKeys implHashes = + let namesSorted = Data.List.sort (Data.Set.toList nameKeys) + in hashModuleImplEntries (InterfaceFiles.mhImplHash moduleHashInfo) namesSorted $ \name sink -> + feedName name sink >> feedHashBytes (M.findWithDefault B.empty name implHashes) sink diff --git a/compiler/lib/src/Acton/Reachability.hs b/compiler/lib/src/Acton/Reachability.hs new file mode 100644 index 000000000..53f22b251 --- /dev/null +++ b/compiler/lib/src/Acton/Reachability.hs @@ -0,0 +1,2586 @@ +-- SPDX-License-Identifier: BSD-3-Clause + +-- | Extract and close reachability dependencies for selective compilation. +-- +-- The front pass traverses typed syntax and records exact dependencies on +-- top-level names and qualified members. 'prepareReachabilityRows' assigns +-- those summaries to the independently loadable rows written to TYDB. For a +-- deferred back pass, 'selectProgram' follows those persisted facts from the +-- executable roots and returns the complete selection of syntax rows. +-- +-- 'ReachabilityRows' contains the persisted representation. 'SelectiveBack' +-- supplies exact TYDB reads and turns the resulting selection into partial +-- Acton modules. This module performs no interface-file IO and does not run +-- compiler passes. +module Acton.Reachability + ( prepareInterfaceRows + , prepareReachabilityRows + , TopKey(..) + , ReachLookup(..) + , Selection(..) + , SelectedRow(..) + , selectedTops + , selectedOpaqueTops + , selectedMembers + , selectedAttrs + , selectedStaticInitializers + , selectedInstanceInitializers + , selectedGenerated + , emptySelection + , SelectionError(..) + , selectProgram + ) where + +import qualified Acton.Builtin as Builtin +import qualified Acton.Env as Env +import qualified Acton.InterfaceRows as Rows +import qualified Acton.NameInfo as I +import qualified Acton.Names as Names +import qualified Acton.QuickType as QuickType +import qualified Acton.Prim as Prim +import Acton.ReachabilityRows +import qualified Acton.Subst as Subst +import qualified Acton.Syntax as A +import qualified Acton.Types as Types + +import Control.DeepSeq (force) +import Control.Monad (foldM, mapAndUnzipM, unless, when) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, except, runExceptT, throwE) +import Control.Monad.Trans.State.Strict (StateT, get, modify', runStateT) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.IntSet as IntSet +import Data.List (foldl', partition) +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust, mapMaybe) +import qualified Data.Sequence as Seq +import qualified Data.Set as Set + + +-- Lexical environment ----------------------------------------------------------------------------------- + +data ReachScope = TopScope | ContainerScope | LocalScope deriving (Eq, Show) + +data ReachEnv = ReachEnv { + reachTypeEnv :: Env.Env0, + reachLocals :: Set.Set A.Name, + reachGlobals :: Set.Set A.Name, + reachScope :: ReachScope, + reachOwner :: Maybe A.QName, + reachReflectiveOwner :: Bool, + reachImplicitAttrs :: Set.Set A.Name, + reachDeferredLocals :: Set.Set A.Name, + reachClassInitParams :: I.TEnv, + reachDirectMembers :: Map.Map A.Name (MemberRef,Bool) + } + +topReachEnv :: Env.Env0 -> Set.Set A.Name -> ReachEnv +topReachEnv env globals = ReachEnv env Set.empty globals TopScope Nothing False Set.empty Set.empty [] Map.empty + +localReachEnv :: Env.Env0 -> Set.Set A.Name -> ReachEnv +localReachEnv env globals = ReachEnv env Set.empty globals LocalScope Nothing False Set.empty Set.empty [] Map.empty + +withReachOwner :: A.QName -> ReachEnv -> ReachEnv +withReachOwner qn env = env{ reachOwner = Just (A.GName m n) } + where (m,n) = canonicalQName env qn + +defineOnly :: I.TEnv -> ReachEnv -> ReachEnv +defineOnly te env = env{ reachTypeEnv = Env.define te (reachTypeEnv env) } + +defineLocal :: I.TEnv -> ReachEnv -> ReachEnv +defineLocal te env = (defineOnly te env){ reachLocals = Set.union (reachLocals env) (Set.fromList $ map fst te) } + +defineBound :: (Names.Vars a, QuickType.EnvOf a) => a -> ReachEnv -> ReachEnv +defineBound syntax env = (defineOnly (QuickType.envOf syntax) env) { + reachLocals = Set.union (reachLocals env) (Set.fromList $ Names.bound syntax) + } + +advanceReachEnv :: I.TEnv -> ReachEnv -> ReachEnv +advanceReachEnv te env = case reachScope env of + TopScope -> defineOnly te env + LocalScope -> defineLocal te env + ContainerScope -> (defineOnly te env) { + reachLocals = Set.union (reachLocals env) deferred + } + where deferred = Set.intersection (Set.fromList $ map fst te) (reachDeferredLocals env) + +enterLocal :: ReachEnv -> ReachEnv +enterLocal env = env{ reachScope = LocalScope } + +enterContainer :: ReachEnv -> ReachEnv +enterContainer env = env{ reachScope = ContainerScope } + +clearContainerBindings :: ReachEnv -> ReachEnv +clearContainerBindings env = env { + reachImplicitAttrs = Set.empty, + reachDeferredLocals = Set.empty, + reachClassInitParams = [], + reachDirectMembers = Map.empty + } + +classInitParams :: A.Suite -> I.TEnv +classInitParams body = + [ binding + | A.Decl _ decls <- body + , decl@A.Def{} <- decls + , A.dname decl == Builtin.initKW + , binding@(n,_) <- QuickType.envOf (A.pos decl) + , Names.isWitness n + ] + +classEquationEnv :: ReachEnv -> [A.Pattern] -> ReachEnv +classEquationEnv env [A.PVar _ n (Just _)] + | reachScope env == ContainerScope + , Names.isWitness n = defineLocal (reachClassInitParams env) env +classEquationEnv env _ = env + +setDirectMembers :: A.Suite -> ReachEnv -> ReachEnv +setDirectMembers body env = env{ reachDirectMembers = Map.fromList $ concatMap classify bodyEnv } + where + bodyEnv = QuickType.envOf body + classify (n,I.NDef _ deco _) = [(n,(MethodRef n,deco == A.Static))] + classify (n,I.NSig sc deco _) + | deco == A.Property = [(n,(AttrRef n,deco == A.Static))] + | A.TFun{} <- A.sctype sc = [(n,(MethodRef n,deco == A.Static))] + -- The Normalizer consumes class-scope witness equations before deciding + -- whether they become globals, constructor locals, or instance fields. + -- Keep that defining syntax row through its exact owner; explicit + -- receiver.witness access remains ordinary instance dispatch. + classify (n,I.NVar{}) + | Names.isWitness n = [(n,(AttrRef n,True))] + classify (n,I.NVar{}) = [(n,(AttrRef n,False))] + classify (n,I.NSVar{}) = [(n,(AttrRef n,False))] + classify _ = [] + +defineTVars :: A.QBinds -> ReachEnv -> ReachEnv +defineTVars q env = env{ reachTypeEnv = Env.defineTVars q (reachTypeEnv env) } + +-- Reachability walk ----------------------------------------------------------------------------------- + +-- All structural recursion is Names.summ with the hooks below; the rest of +-- this section is the semantic content only: declaration headers, name and +-- receiver classification, and the Normalizer-anticipating condition and +-- iterator reach. +reachWalk :: Names.Walk ReachEnv ReachSummary +reachWalk = (Names.plainWalk :: Names.Walk ReachEnv ReachSummary) { + Names.wSeq = \env s -> advanceReachEnv (QuickType.envOf s) env, + Names.wSuiteEnv = \env b -> advanceReachEnv (QuickType.envOf b) env, + Names.wDecls = \env ds -> advanceReachEnv (QuickType.envOf ds) env, + Names.wDecl = summarizeDeclHeader, + Names.wLocal = enterLocal, + Names.wLet = \env ss -> defineLocal (QuickType.envOf ss) env, + Names.wPar = \env n mt -> defineLocal [(n, I.NVar $ typedParam env n mt)] env, + Names.wPat = flip defineBound, + Names.wItem = flip defineBound, + Names.wExcept = flip defineBound, + Names.wQBinds = flip defineTVars, + Names.wAssignRhs = classEquationEnv, + Names.wVar = needValueQName, + Names.wDot = \env e n -> summarizeReceiver env e <> memberSelection env e n, + Names.wCall = \env f -> maybe mempty (singletonReach . uncurry Construct) (constructorTarget env f), + Names.wCond = booleanReach, + Names.wIter = nextReach, + Names.wTarg = assignTarget, + Names.wTCon = typeConReach, + Names.wTypeName = needTypeQName } + +summReach :: Names.Summ a => ReachEnv -> a -> ReachSummary +summReach = Names.summ reachWalk + +summarizeSuite :: ReachEnv -> A.Suite -> ReachSummary +summarizeSuite = Names.summSuite reachWalk + +summarizeStmt :: ReachEnv -> A.Stmt -> ReachSummary +summarizeStmt = summReach + +summarizeDecl :: ReachEnv -> A.Decl -> ReachSummary +summarizeDecl env decl = header <> summarizeSuite bodyEnv (A.declbody decl) + where (header,bodyEnv) = summarizeDeclHeader env decl + +summarizeType :: ReachEnv -> A.Type -> ReachSummary +summarizeType = summReach + +summarizeCondition :: ReachEnv -> A.Expr -> ReachSummary +summarizeCondition env expr = summReach env expr <> booleanReach env expr + +-- Assignment targets that are implicit actor attributes dispatch on the owner. +assignTarget :: ReachEnv -> A.Pattern -> ReachSummary +assignTarget env pat = case pat of + A.PVar _ name _ + | Set.member name (reachImplicitAttrs env) + , Just (A.GName mn owner) <- reachOwner env + -> singletonReach (Dispatch mn owner $ AttrRef name) + A.PParen _ p -> assignTarget env p + A.PTuple _ pos kwd -> posTargets pos <> kwdTargets kwd + A.PList _ items rest -> foldMap (assignTarget env) items <> foldMap (assignTarget env) rest + _ -> mempty + where + posTargets pos = case pos of + A.PosPat p rest -> assignTarget env p <> posTargets rest + A.PosPatStar p -> assignTarget env p + A.PosPatNil -> mempty + kwdTargets kwd = case kwd of + A.KwdPat _ p rest -> assignTarget env p <> kwdTargets rest + A.KwdPatStar p -> assignTarget env p + A.KwdPatNil -> mempty + +-- A type constructor in ordinary type position is declaration-only interest; +-- an alias is code and stays a full Need. +typeConReach :: ReachEnv -> A.QName -> ReachSummary +typeConReach env qn + | typeAlias (reachTypeEnv env) qn = needTypeQName env qn + | otherwise = declareTypeQName env qn + + +summarizeDeclHeader :: ReachEnv -> A.Decl -> (ReachSummary,ReachEnv) +summarizeDeclHeader env decl = case decl of + A.Def _ n q p k a _ _ fx _ -> (reflect <> summReach env q <> parReach <> kwdReach <> + summReach envQ a <> summReach envQ fx, + bodyEnv) + where reflect + | reachReflectiveOwner env, + n == Builtin.getAttrKW, + Just owner <- reachOwner env + = reflectReach env owner + | otherwise = mempty + envQ = defineTVars q ((enterLocal env){ reachReflectiveOwner = False }) + (parReach,envP) = Names.summPosPar reachWalk envQ p + (kwdReach,bodyEnv) = Names.summKwdPar reachWalk envP k + A.Actor _ n q p k b _ -> (summReach env q <> parReach <> kwdReach, bodyEnv) + where (live,deferredNames) = QuickType.actorBindings p k b + attrs = Set.fromList live + deferred = Set.fromList deferredNames + envQ = (setDirectMembers b $ withReachOwner (A.NoQ n) $ defineTVars q (enterContainer env)) { + reachImplicitAttrs = attrs, + reachDeferredLocals = deferred + } + selfType = A.tCon $ A.TC (A.NoQ n) (map A.tVar $ A.qbound q) + envSelf = defineLocal [(Names.self, I.NVar selfType)] envQ + (parReach,envP) = Names.summPosPar reachWalk envSelf p + (kwdReach,envK) = Names.summKwdPar reachWalk envP k + bodyEnv = envK{ reachLocals = Set.difference (reachLocals envK) attrs } + A.Class _ n q cs b _ -> (summReach env q <> foldMap (summarizeBaseTCon envQ) cs, bodyEnv) + where envQ = defineTVars q (enterLocal env) + bodyEnv = (setDirectMembers b $ clearContainerBindings $ + withReachOwner (A.NoQ n) $ + defineTVars (Env.selfQuant (A.NoQ n) q) (enterContainer env)) { + reachReflectiveOwner = True, + reachClassInitParams = classInitParams b + } + A.Protocol _ n q ps b _ -> (summReach env q <> foldMap (summarizeBaseTCon envQ) ps, bodyEnv) + where envQ = defineTVars q (enterLocal env) + bodyEnv = setDirectMembers b $ clearContainerBindings $ withReachOwner (A.NoQ n) $ + defineTVars (Env.selfQuant (A.NoQ n) q) (enterContainer env) + A.Typedef _ _ q t _ -> (summReach env q <> summReach envQ t, envQ) + where envQ = defineTVars q (enterLocal env) + A.Extension _ q c ps b _ -> (summReach env q <> summarizeBaseTCon envQ c <> + foldMap (summarizeBaseTCon envQ) ps, bodyEnv) + where envQ = defineTVars q (enterLocal env) + bodyEnv = setDirectMembers b $ clearContainerBindings $ withReachOwner (A.tcname c) $ + defineTVars (Env.selfQuant (A.tcname c) q) (enterContainer env) + + +-- Selection classification ------------------------------------------------------------------------------ + +constructorTarget :: ReachEnv -> A.Expr -> Maybe (A.ModName,A.Name) +constructorTarget env (A.TApp _ f _) = constructorTarget env f +constructorTarget env (A.Paren _ f) = constructorTarget env f +constructorTarget env (A.Var _ qn) = case Env.findQName qn (reachTypeEnv env) of + I.NClass{} -> target + I.NAct{} -> target + I.NExt{} -> target + _ -> Nothing + where + target = case canonicalQName env qn of + key@(mn,_) + | mn /= Prim.mPrim -> Just key + _ -> Nothing +constructorTarget _ _ = Nothing + +-- A class/actor value can be aliased or passed through a higher-order call and +-- invoked later. Treat the value escape as construction interest; direct +-- class-qualified member access uses summarizeReceiver below and remains a +-- static selection without construction. +needValueQName :: ReachEnv -> A.QName -> ReachSummary +needValueQName env qn = needQName env qn <> valueEscape + where + target = canonicalQName env qn + valueEscape + | localOrMember = mempty + | fst target == Prim.mPrim = mempty + | target == (Builtin.mBuiltin,Builtin.nSerialize) = dynamic + | target == (Builtin.mBuiltin,Builtin.nDeserialize) = dynamic + | otherwise = case Env.tryQName qn (reachTypeEnv env) of + Just I.NClass{} -> construct + Just I.NAct{} -> construct + Just I.NExt{} -> construct + _ -> mempty + localOrMember = case qn of + A.NoQ n -> n == Names.selfKW' || + Set.member n (reachLocals env) || + isJust (ownerMember env n) + _ -> False + construct = singletonReach (uncurry Construct target) + dynamic = singletonReach DynamicSerialization + +summarizeReceiver :: ReachEnv -> A.Expr -> ReachSummary +summarizeReceiver env expr + | Just _ <- directClassTarget env expr + = staticReceiver expr + | otherwise = summReach env expr + where + staticReceiver (A.Var _ qn) = needQName env qn + staticReceiver (A.TApp _ e ts) = staticReceiver e <> foldMap (summReach env) ts + staticReceiver (A.Paren _ e) = staticReceiver e + staticReceiver e = summReach env e + +memberSelection :: ReachEnv -> A.Expr -> A.Name -> ReachSummary +memberSelection env e n + | n == Builtin.initKW, + Just _ <- directProtocolTarget env e + = mempty + | Just owner <- directClassTarget env e + = select Direct owner + | Just owner <- constructedReceiverTarget env e + = select Dispatch owner + | otherwise = case typ of + A.TCon _ tc -> select Dispatch (canonicalQName env $ A.tcname tc) + A.TVar _ tv -> select Dispatch (canonicalQName env $ A.tcname $ Env.findTVBound (reachTypeEnv env) tv) + A.TTuple _ _ k + | n `elem` Builtin.valueKWs -> select Dispatch (canonicalQName env $ A.tcname Builtin.cValue) + | tupleField n k -> mempty + | otherwise -> reachError env ("tuple has no field " ++ A.rawstr n) e + t -> reachError env ("impossible receiver type " ++ show t ++ " for ." ++ A.rawstr n) e + where typ = expandReachType (reachTypeEnv env) $ + QuickType.typeOf (reachTypeEnv env) e + select edge owner = singletonReach (uncurry edge owner $ memberRef env owner n) + +directClassTarget :: ReachEnv -> A.Expr -> Maybe (A.ModName,A.Name) +directClassTarget env (A.TApp _ e _) = directClassTarget env e +directClassTarget env (A.Paren _ e) = directClassTarget env e +directClassTarget env (A.Var _ qn) = case Env.findQName qn (reachTypeEnv env) of + I.NClass{} -> Just (canonicalQName env qn) + I.NProto{} -> Just (canonicalQName env qn) + I.NExt{} -> Just (canonicalQName env qn) + _ -> Nothing +directClassTarget _ _ = Nothing + +directProtocolTarget :: ReachEnv -> A.Expr -> Maybe (A.ModName,A.Name) +directProtocolTarget env (A.TApp _ e _) = directProtocolTarget env e +directProtocolTarget env (A.Paren _ e) = directProtocolTarget env e +directProtocolTarget env (A.Var _ qn) = case Env.findQName qn (reachTypeEnv env) of + I.NProto{} -> Just (canonicalQName env qn) + _ -> Nothing +directProtocolTarget _ _ = Nothing + +constructedReceiverTarget :: ReachEnv -> A.Expr -> Maybe (A.ModName,A.Name) +constructedReceiverTarget env (A.Call _ fun _ _) = constructorTarget env fun +constructedReceiverTarget env (A.Paren _ expr) = constructedReceiverTarget env expr +constructedReceiverTarget _ _ = Nothing + +memberRef :: ReachEnv -> (A.ModName,A.Name) -> A.Name -> MemberRef +memberRef _ _ n | n == Builtin.initKW = MethodRef n +memberRef _ _ n@(A.Internal A.Witness _ _) = AttrRef n +memberRef env target@(m,c) n = case Env.findAttrInfo' (reachTypeEnv env) (A.GName m c) n of + Just info -> memberRefFromInfo env target n info + Nothing -> reachError0 env ("missing member " ++ targetText m c ++ "." ++ A.rawstr n) + +memberRefFromInfo :: ReachEnv -> (A.ModName,A.Name) -> A.Name -> I.NameInfo -> MemberRef +memberRefFromInfo env (m,c) n info = case info of + I.NDef{} -> MethodRef n + I.NSig sc dec _ + | dec == A.Property -> AttrRef n + | A.TFun{} <- A.sctype sc -> MethodRef n + | otherwise -> reachError0 env ("non-property, non-method signature for " ++ targetText m c ++ "." ++ A.rawstr n) + I.NVar{} -> AttrRef n + I.NSVar{} -> AttrRef n + _ -> reachError0 env ("non-member info " ++ show info ++ " for " ++ targetText m c ++ "." ++ A.rawstr n) + +reflectReach :: ReachEnv -> A.QName -> ReachSummary +reflectReach env qn = singletonReach (uncurry Reflect $ canonicalQName env qn) + +needQName :: ReachEnv -> A.QName -> ReachSummary +needQName _ (A.NoQ n) + | n == Names.selfKW' = mempty +needQName env (A.NoQ n) + | Set.member n (reachLocals env) = mempty + | Just edge <- ownerMember env n + = singletonReach edge + | Set.member n (reachGlobals env) = singletonReach (uncurry Need $ canonicalQName env $ A.NoQ n) + | Just I.NAlias{} <- rawInfo = singletonReach (uncurry Need $ canonicalQName env $ A.NoQ n) + | I.NVar{} <- info = reachError0 env ("untracked local variable " ++ A.rawstr n) + | I.NSVar{} <- info = reachError0 env ("untracked state variable " ++ A.rawstr n) + | otherwise = reachError0 env ("untracked unqualified name " ++ A.rawstr n ++ " with " ++ show info) + where rawInfo = Env.lookupName n (reachTypeEnv env) + info = Env.findQName (A.NoQ n) (reachTypeEnv env) +needQName env qn = singletonReach (uncurry Need $ canonicalQName env qn) + +needTypeQName :: ReachEnv -> A.QName -> ReachSummary +needTypeQName env qn = singletonReach (uncurry Need $ canonicalQName env qn) + +declareTypeQName :: ReachEnv -> A.QName -> ReachSummary +declareTypeQName env qn = singletonReach (uncurry Declare $ canonicalQName env qn) + +ownerMember :: ReachEnv -> A.Name -> Maybe ReachEdge +ownerMember env n = case reachOwner env of + Just owner@(A.GName m c) + | Set.member n (reachImplicitAttrs env) + -> Just (Dispatch m c $ AttrRef n) + | Just (ref,isStatic) <- Map.lookup n (reachDirectMembers env) + -> Just ((if isStatic then Direct else Dispatch) m c ref) + | Just memberInfo <- info, + isMemberInfo memberInfo -> Just (memberEdge memberInfo m c $ memberRefFromInfo env (m,c) n memberInfo) + | otherwise -> Nothing + where info = Env.findAttrInfo' (reachTypeEnv env) owner n + isMemberInfo I.NDef{} = True + isMemberInfo I.NSig{} = True + isMemberInfo I.NVar{} = True + isMemberInfo I.NSVar{} = True + isMemberInfo _ = False + memberEdge (I.NDef _ A.Static _) = Direct + memberEdge (I.NSig _ A.Static _) = Direct + memberEdge _ = Dispatch + Just qn -> reachError0 env ("non-global owner " ++ show qn) + Nothing -> Nothing + +canonicalQName :: ReachEnv -> A.QName -> (A.ModName,A.Name) +canonicalQName env qn = case Env.unalias (reachTypeEnv env) qn of + A.GName m n -> (m,n) + qn' -> reachError0 env ("non-global target " ++ show qn' ++ " from " ++ show qn) + +tupleField :: A.Name -> A.Type -> Bool +tupleField n (A.TRow _ _ n' _ r) = n == n' || tupleField n r +tupleField _ A.TStar{} = True +tupleField _ A.TNil{} = False +tupleField n r = error ("Acton.Reachability: impossible tuple row " ++ show r ++ " while finding " ++ A.rawstr n) + +targetText :: A.ModName -> A.Name -> String +targetText (A.ModName ns) n = concatMap ((++ ".") . A.rawstr) ns ++ A.rawstr n + +reachError :: ReachEnv -> String -> A.Expr -> a +reachError env msg e = reachError0 env (msg ++ " in " ++ show e) + +reachError0 :: ReachEnv -> String -> a +reachError0 env msg = error ("Acton.Reachability: " ++ owner ++ msg) + where owner = maybe "" (\qn -> "while walking " ++ show qn ++ ": ") (reachOwner env) + + + +typedParam :: ReachEnv -> A.Name -> Maybe A.Type -> A.Type +typedParam _ _ (Just t) = t +typedParam env n Nothing = reachError0 env ("untyped reconstructed parameter " ++ A.rawstr n) + + +typeAlias :: Env.Env0 -> A.QName -> Bool +typeAlias env = isJust . typeAliasInfo env + +typeAliasInfo :: Env.Env0 + -> A.QName + -> Maybe (A.QBinds,A.Type) +typeAliasInfo env qn = case qn of + A.NoQ name -> fromInfo (Env.lookupName name env) + A.GName mn name + | Just mn == Env.thismod env -> fromInfo (Env.lookupName name env) + | otherwise -> fromModule mn name + A.QName mn name -> fromModule mn name + where + fromModule mn name = case Env.lookupModuleInfo mn env of + Just info -> fromInfo (Env.moduleLookupName info name) + Nothing -> Nothing + fromInfo (Just (I.NType q typ _)) + = Just (q,typ) + fromInfo (Just (I.NAlias qn')) = typeAliasInfo env qn' + fromInfo _ = Nothing + +expandReachType :: Env.Env0 -> A.Type -> A.Type +expandReachType env typ@(A.TCon _ (A.TC qn args)) + = case typeAliasInfo env qn of + Just (q,target) -> expandReachType env $ + Subst.vsubst (A.qbound q `zip` args) target + Nothing -> typ +expandReachType _ typ = typ + +summarizeBaseTCon :: ReachEnv -> A.TCon -> ReachSummary +summarizeBaseTCon env (A.TC qn ts) = needTypeQName env qn <> foldMap (summReach env) ts + + +-- Post-front calls -------------------------------------------------------------------------------------- + +-- Normalizer makes truth conversion explicit. Record precisely the method +-- it will introduce, while leaving an already-bool condition alone. +booleanReach :: ReachEnv -> A.Expr -> ReachSummary +booleanReach env expr + | typ == Builtin.tBool = mempty + | A.TOpt _ inner <- typ + = memberReachForType env inner Builtin.boolKW + | A.BinOp _ left op right <- expr + , op `elem` [A.And,A.Or] = booleanReach env left <> booleanReach env right + | otherwise = memberSelection env expr Builtin.boolKW + where typ = expandReachType (reachTypeEnv env) $ + QuickType.typeOf (reachTypeEnv env) expr + +-- Types has already inserted __iter__. Normalizer stores that iterator and +-- calls __next__ for each iteration; its specialized range loop calls the +-- opaque primitive instead. +nextReach :: ReachEnv -> A.Expr -> ReachSummary +nextReach env expr + | isRangeIterator env expr = needQName env Prim.primUNext + | otherwise = memberSelection env expr Builtin.nextKW + +isRangeIterator :: ReachEnv -> A.Expr -> Bool +isRangeIterator env (A.Call _ fun (A.PosArg arg A.PosNil) A.KwdNil) + | iteratorCall fun = QuickType.typeOf (reachTypeEnv env) arg == Builtin.tRange +isRangeIterator env (A.Paren _ expr) = isRangeIterator env expr +isRangeIterator _ _ = False + +iteratorCall :: A.Expr -> Bool +iteratorCall (A.Dot _ _ name) = name == Builtin.iterKW +iteratorCall (A.TApp _ fun _) = iteratorCall fun +iteratorCall _ = False + +memberReachForType :: ReachEnv -> A.Type -> A.Name -> ReachSummary +memberReachForType env typ name = case expandReachType (reachTypeEnv env) typ of + A.TCon _ con -> dispatch (A.tcname con) + A.TVar _ var -> dispatch (A.tcname $ Env.findTVBound (reachTypeEnv env) var) + A.TTuple{} -> dispatch (A.tcname Builtin.cValue) + _ -> reachError0 env + ("impossible generated receiver type " ++ show typ ++ + " for ." ++ A.rawstr name) + where + dispatch qn = singletonReach (uncurry Dispatch owner $ memberRef env owner name) + where owner = canonicalQName env qn + + +-- Syntax partitioning ---------------------------------------------------------------------------------- + +data ActorPlan = ActorPlan + { actorLocals :: Set.Set A.Name + , actorParameterAttrs :: [A.Name] + } deriving Eq + +data ContainerKind + = KActor ActorPlan + | KClass (Set.Set A.Name) + | KProtocol + | KExtension + deriving Eq + +data InitRoute = RouteTop | RouteAttrs [A.Name] | RouteRest deriving Eq + +data AttrAccum = AttrAccum + { accumDecls :: [Rows.Fragment] + , accumInits :: [Rows.Fragment] + } + +data PrepareState = PrepareState + { preparedMethods :: Map.Map A.Name [A.Decl] + , preparedAttrs :: Map.Map A.Name AttrAccum + , preparedRest :: [Rows.Fragment] + , preparedConstructor :: Maybe A.Decl + , methodCounts :: Map.Map A.Name Int + , nextHole :: Int + } + +emptyPrepareState :: PrepareState +emptyPrepareState = PrepareState Map.empty Map.empty [] Nothing Map.empty 0 + +prepareInterfaceRows :: Env.Env0 -> A.Module -> Rows.RowResult Rows.InterfaceRows +prepareInterfaceRows env (A.Module mn imps doc suite) = do + (stmts, containers) <- mapAndUnzipM (prepareTopStmt env partitionEnv) suite + let prepared = concat containers + names = map (Rows.shapeName . fst) prepared + when (length names /= Set.size (Set.fromList names)) $ + Rows.rowError "duplicate top-level container names" + return Rows.InterfaceRows + { Rows.rowModuleName = mn + , Rows.rowImports = imps + , Rows.rowDoc = doc + , Rows.rowHasNotImpl = A.hasNotImpl suite + , Rows.rowStatements = stmts + , Rows.rowShapes = Map.fromList [ (Rows.shapeName shape, shape) | (shape, _) <- prepared ] + , Rows.rowMembers = Map.fromList [ (Rows.shapeName shape, members) | (shape, members) <- prepared ] + } + where + partitionEnv = Env.define (QuickType.envOfTopSuite suite) (Env.setMod mn env) + +prepareTopStmt :: Env.Env0 + -> Env.Env0 + -> A.Stmt + -> Rows.RowResult (Rows.StoredStmt, [(Rows.ContainerShape, Map.Map Rows.MemberKey Rows.MemberContent)]) +prepareTopStmt semanticEnv backendEnv (A.Decl l decls) = do + prepared <- mapM prepare decls + return (Rows.StoredDecls l (map fst prepared), [ row | (_, Just row) <- prepared ]) + where + prepare decl + | isContainer decl = do + row <- prepareContainer semanticEnv backendEnv decl + return (Rows.StoredContainer (Names.dname' decl), Just row) + | otherwise = return (Rows.StoredInline decl, Nothing) +prepareTopStmt _ _ stmt = return (Rows.StoredWhole (wholeStmtOwners stmt) stmt, []) + +isContainer :: A.Decl -> Bool +isContainer A.Actor{} = True +isContainer A.Class{} = True +isContainer A.Protocol{} = True +isContainer A.Extension{} = True +isContainer _ = False + +prepareContainer :: Env.Env0 + -> Env.Env0 + -> A.Decl + -> Rows.RowResult (Rows.ContainerShape, Map.Map Rows.MemberKey Rows.MemberContent) +prepareContainer semanticEnv backendEnv decl = do + constructor <- classConstructor decl + let (kind0, head', suite) = containerParts decl + kind = case kind0 of + KClass _ -> KClass (classAttrs semanticEnv backendEnv $ Names.dname' decl) + _ -> kind0 + initial = case kind of + KActor plan -> foldl' (flip ensureAttr) emptyPrepareState (actorParameterAttrs plan) + _ -> emptyPrepareState + (shape, state0) <- prepareSuite (containerBodyEnv backendEnv decl) + kind (isConstructor constructor) RouteTop suite initial + state1 <- maybe (return state0) (prepareConstructor backendEnv suite state0) constructor + return + ( Rows.ContainerShape (Names.dname' decl) head' shape + , finishMembers kind state1 + ) + where + isConstructor Nothing _ = False + isConstructor (Just target) candidate = target == candidate + +containerBodyEnv :: Env.Env0 -> A.Decl -> Env.Env0 +containerBodyEnv env A.Actor{A.dname=n,A.qbinds=q,A.pos=p,A.kwd=k} = + Env.define (QuickType.envOf p ++ QuickType.envOf k) $ + Env.setInAct $ + Env.define [(Builtin.selfKW, I.NVar $ A.tCon tc)] $ + Env.defineTVars q env + where tc = A.TC (A.NoQ n) (map A.tVar $ A.qbound q) +containerBodyEnv env _ = env + +containerParts :: A.Decl -> (ContainerKind, Rows.ContainerHead, A.Suite) +containerParts (A.Actor l n q p k suite doc) = + (KActor (makeActorPlan p k suite), Rows.ActorHead l n q p k doc, suite) +containerParts (A.Class l n q bases suite doc) = + (KClass Set.empty, Rows.ClassHead l n q bases doc, suite) +containerParts (A.Protocol l n q bases suite doc) = + (KProtocol, Rows.ProtocolHead l n q bases doc, suite) +containerParts (A.Extension l q con bases suite doc) = + (KExtension, Rows.ExtensionHead l q con bases doc, suite) +containerParts decl = error ("containerParts: " ++ show decl) + +classAttrs :: Env.Env0 -> Env.Env0 -> A.Name -> Set.Set A.Name +classAttrs semanticEnv backendEnv name = case Env.tryQName qn semanticEnv of + Just (I.NClass _ _ semanticMembers _) -> attrs semanticMembers `Set.union` backendAttrs + Just I.NProto{} -> backendAttrs + Just I.NExt{} -> backendAttrs + Just info -> expected info + Nothing -> backendAttrs + where + backendAttrs = case Env.findQName qn backendEnv of + I.NClass _ _ members _ -> attrs members + info -> expected info + attrs members = Set.fromList [ member | (member,info) <- members, isAttr info ] + isAttr I.NVar{} = True + isAttr I.NSVar{} = True + isAttr _ = False + expected info = error ("prepareInterfaceRows: class info expected for " ++ show name ++ + ", got " ++ show info) + qn = A.NoQ name + +makeActorPlan :: A.PosPar -> A.KwdPar -> A.Suite -> ActorPlan +makeActorPlan p k body = ActorPlan locals parameterAttrs + where + (liveVars,_) = QuickType.actorBindings p k body + paramNames = Names.bound (p,k) + locals = Set.fromList (Env.uniqueNames (liveVars ++ Names.bound (filter A.isDecl body))) + parameterAttrs = filter (`Set.member` locals) paramNames + +prepareSuite :: Env.Env0 + -> ContainerKind + -> (A.Decl -> Bool) + -> InitRoute + -> A.Suite + -> PrepareState + -> Rows.RowResult (Rows.SuiteShape, PrepareState) +prepareSuite env kind constructor route suite state = do + (stmts, state', _) <- foldM prepare ([], state, env) suite + return (Rows.SuiteShape (reverse stmts), state') + where + prepare (stmts, acc, stmtEnv) stmt = do + (stored, acc') <- prepareStmt stmtEnv kind constructor route stmt acc + return (stored : stmts, acc', Env.define (QuickType.envOf stmt) stmtEnv) + +prepareStmt :: Env.Env0 + -> ContainerKind + -> (A.Decl -> Bool) + -> InitRoute + -> A.Stmt + -> PrepareState + -> Rows.RowResult (Rows.ShapeStmt, PrepareState) +prepareStmt env kind@(KActor plan) constructor RouteTop stmt state + | not (A.isDecl stmt), not (A.isSig stmt) = do + attrs <- prunableActorStmtAttrs env plan stmt + let state' + | null attrs = foldl' (flip ensureAttr) state (actorStmtAttrs plan stmt) + | otherwise = state + prepareStmt env kind constructor + (if null attrs then RouteRest else RouteAttrs (Env.uniqueNames attrs)) stmt state' +prepareStmt env kind@(KClass attrs) constructor RouteTop stmt state + | not (A.isDecl stmt), not (A.isSig stmt) = do + names <- classStmtAttrs attrs stmt + prepareStmt env kind constructor + (if null names then RouteRest else RouteAttrs names) stmt state +prepareStmt env kind constructor route (A.If l branches elseSuite) state = do + (storedBranches, state1) <- foldM prepareBranch ([], state) branches + (storedElse, state2) <- prepareSuite env kind constructor + (branchRoute kind route elseSuite) elseSuite state1 + return (Rows.IfStmt l (reverse storedBranches) storedElse, state2) + where + prepareBranch (stored, acc) (A.Branch condition body) = do + (body', acc') <- prepareSuite env kind constructor + (branchRoute kind route body) body acc + return ((condition, body') : stored, acc') +prepareStmt _ _ constructor _ (A.Decl l decls) state = do + (stored, state') <- foldM prepare ([], state) decls + return (Rows.DeclStmt l (reverse stored), state') + where + prepare (decls, acc) decl@A.Def{} = do + let name = A.dname decl + ordinal = Map.findWithDefault 0 name (methodCounts acc) + slot = Rows.MethodSlot name ordinal (constructor decl) (Rows.methodHeader decl) + acc' + | constructor decl = acc { preparedConstructor = Just decl } + | otherwise = acc + { preparedMethods = Map.insertWith (flip (++)) name [decl] (preparedMethods acc) + , methodCounts = Map.insert name (ordinal + 1) (methodCounts acc) + } + when (constructor decl && preparedConstructor acc /= Nothing) $ + Rows.rowError "multiple constructor slots" + return (Rows.MethodDecl slot : decls, acc') + prepare _ decl | isContainer decl = Rows.rowError "nested container declarations are not supported" + prepare (decls, acc) decl = return (Rows.InlineDecl decl : decls, acc) +prepareStmt _ kind _ (RouteAttrs names) stmt state = do + owners <- initializerStmtAttrs kind names stmt + return (Rows.HoleStmt hole, addAttrInitializerGroup owners fragment state') + where + (hole, state') = allocateHole state + fragment = Rows.SuiteFragment hole stmt +prepareStmt _ _ _ RouteRest stmt state = + return (Rows.HoleStmt hole, addRestInitializer (Rows.SuiteFragment hole stmt) state') + where + (hole, state') = allocateHole state +prepareStmt _ _ _ _ stmt@(A.Signature _ names _ A.Property) state + | null names = Rows.rowError "empty property signature" + | otherwise = + return (Rows.HoleStmt hole, addAttrDeclaration names (Rows.SuiteFragment hole stmt) state') + where + (hole, state') = allocateHole state +prepareStmt _ _ _ _ stmt state = return (Rows.InlineStmt stmt, state) + +allocateHole :: PrepareState -> (Int, PrepareState) +allocateHole state = (nextHole state, state { nextHole = nextHole state + 1 }) + +-- A conditional keeps its shape in the container row, but each branch body is +-- stored only with the attributes assigned by that branch. Statements which +-- assign a particular attribute narrow further to that attribute; shared +-- preparatory statements remain with the branch group. +branchRoute :: ContainerKind -> InitRoute -> A.Suite -> InitRoute +branchRoute kind (RouteAttrs names) suite = + case filter (`Set.member` assigned) names of + [] -> RouteRest + selected -> RouteAttrs selected + where assigned = Set.fromList (initializerSuiteAttrs kind suite) +branchRoute _ route _ = route + +initializerSuiteAttrs :: ContainerKind -> A.Suite -> [A.Name] +initializerSuiteAttrs (KActor plan) suite = + [ name | name <- Env.uniqueNames (Names.bound suite) + , Set.member name (actorLocals plan) + ] +initializerSuiteAttrs (KClass attrs) suite = + [ name | name <- Env.uniqueNames (Names.assigned suite) + , Set.member name attrs + ] +initializerSuiteAttrs _ _ = [] + +initializerStmtAttrs :: ContainerKind -> [A.Name] -> A.Stmt -> Rows.RowResult [A.Name] +initializerStmtAttrs kind owners stmt = do + assigned <- case kind of + KActor plan -> return (actorStmtAttrs plan stmt) + KClass attrs -> classStmtAttrs attrs stmt + _ -> return [] + let assignedSet = Set.fromList assigned + exact = filter (`Set.member` assignedSet) owners + return (if null assigned then owners else exact) + +actorStmtAttrs :: ActorPlan -> A.Stmt -> [A.Name] +actorStmtAttrs _ (A.VarAssign _ patterns _) = typedPatternNames patterns +actorStmtAttrs plan (A.Assign _ patterns _) = + [ name | name <- typedPatternNames patterns, Set.member name (actorLocals plan) ] +actorStmtAttrs plan stmt@A.If{} = + [ name | name <- actorStmtNames stmt, Set.member name (actorLocals plan) ] +actorStmtAttrs _ _ = [] + +actorStmtNames :: A.Stmt -> [A.Name] +actorStmtNames = Env.uniqueNames . Names.bound + +prunableActorStmtAttrs :: Env.Env0 -> ActorPlan -> A.Stmt -> Rows.RowResult [A.Name] +prunableActorStmtAttrs env plan stmt@A.VarAssign{A.expr=expr} + | pureActorExpr env expr = actorAttrsOnly plan stmt +prunableActorStmtAttrs env plan stmt@(A.Assign _ _ expr) + | pureActorExpr env expr = actorAttrsOnly plan stmt +prunableActorStmtAttrs env plan stmt@(A.If _ branches elseSuite) + | pureActorBranches env branches elseSuite = actorAttrsOnly plan stmt +prunableActorStmtAttrs _ _ _ = return [] + +actorAttrsOnly :: ActorPlan -> A.Stmt -> Rows.RowResult [A.Name] +actorAttrsOnly plan stmt + | Set.fromList attrs == Set.fromList (actorStmtNames stmt) = return attrs + | otherwise = return [] + where attrs = actorStmtAttrs plan stmt + +pureActorExpr :: Env.Env0 -> A.Expr -> Bool +pureActorExpr _ A.NotImplemented{} = False +pureActorExpr env (A.Let _ suite expr) = + pureActorSuite env suite && pureActorExpr (Env.define (QuickType.envOf suite) env) expr +pureActorExpr env expr = QuickType.fxOf env expr == A.fxPure + +pureActorBranches :: Env.Env0 -> [A.Branch] -> A.Suite -> Bool +pureActorBranches env branches elseSuite = + all pureBranch branches && pureActorSuite env elseSuite + where + pureBranch (A.Branch condition body) = + pureActorExpr env condition && pureActorSuite env body + +pureActorSuite :: Env.Env0 -> A.Suite -> Bool +pureActorSuite _ [] = True +pureActorSuite env (stmt:rest) = + pureActorStmt env stmt && + pureActorSuite (Env.define (QuickType.envOf stmt) env) rest + +pureActorStmt :: Env.Env0 -> A.Stmt -> Bool +pureActorStmt env (A.Assign _ _ expr) = pureActorExpr env expr +pureActorStmt env (A.VarAssign _ _ expr) = pureActorExpr env expr +pureActorStmt env (A.If _ branches elseSuite) = pureActorBranches env branches elseSuite +pureActorStmt _ A.Pass{} = True +pureActorStmt _ A.Signature{} = True +pureActorStmt _ A.Decl{} = True +pureActorStmt _ _ = False + +typedPatternNames :: [A.Pattern] -> [A.Name] +typedPatternNames = Env.uniqueNames . map fst . QuickType.envOf + +classStmtAttrs :: Set.Set A.Name -> A.Stmt -> Rows.RowResult [A.Name] +classStmtAttrs attrs stmt@A.Assign{} = assignedAttrs attrs stmt +classStmtAttrs attrs stmt@A.VarAssign{} = assignedAttrs attrs stmt +classStmtAttrs attrs (A.If _ branches elseSuite) = case branches of + [] -> Rows.rowError "class initializer If has no branches" + _ -> return $ Set.toAscList $ Set.intersection attrs assigned + where + suites = [ body | A.Branch _ body <- branches ] ++ [elseSuite] + assigned = Set.fromList (concatMap Names.assigned suites) +classStmtAttrs _ _ = return [] + +assignedAttrs :: Set.Set A.Name -> A.Stmt -> Rows.RowResult [A.Name] +assignedAttrs attrs stmt + | null selected = return [] + | Set.fromList bound == Set.fromList selected = return (Env.uniqueNames selected) + | otherwise = Rows.rowError "class assignment mixes attribute and non-attribute bindings" + where + bound = Names.bound stmt + selected = filter (`Set.member` attrs) bound + +classConstructor :: A.Decl -> Rows.RowResult (Maybe A.Decl) +classConstructor A.Class{A.dbody=suite} = case direct ++ nested of + [] -> return Nothing + [decl] + | null nested + , A.selfPar decl /= Nothing -> return (Just decl) + | null nested -> Rows.rowError "__init__ has no self parameter" + | otherwise -> Rows.rowError "conditional __init__ declarations are not supported" + _ -> Rows.rowError "multiple __init__ declarations are not supported" + where + direct = + [ decl + | A.Decl _ decls <- suite + , decl@A.Def{} <- decls + , A.dname decl == Builtin.initKW + ] + nested = concatMap nestedConstructors suite +classConstructor _ = return Nothing + +nestedConstructors :: A.Stmt -> [A.Decl] +nestedConstructors (A.If _ branches elseSuite) = + [ decl + | suite <- [ body | A.Branch _ body <- branches ] ++ [elseSuite] + , stmt <- suite + , decl <- inStmt stmt + ] + where + inStmt (A.Decl _ decls) = [ decl | decl@A.Def{} <- decls, A.dname decl == Builtin.initKW ] + inStmt stmt = nestedConstructors stmt +nestedConstructors _ = [] + +addAttrDeclaration :: [A.Name] -> Rows.Fragment -> PrepareState -> PrepareState +addAttrDeclaration names fragment state = + state { preparedAttrs = foldl' add (preparedAttrs state) group } + where + group = Env.uniqueNames names + add attrs name = Map.alter (Just . update) name attrs + update Nothing = AttrAccum [fragment] [] + update (Just old) = old { accumDecls = fragment : accumDecls old } + +ensureAttr :: A.Name -> PrepareState -> PrepareState +ensureAttr name state = + state { preparedAttrs = Map.alter (Just . maybe empty id) name (preparedAttrs state) } + where empty = AttrAccum [] [] + +addAttrInitializerGroup :: [A.Name] -> Rows.Fragment -> PrepareState -> PrepareState +addAttrInitializerGroup names fragment state = + state { preparedAttrs = foldl' add (preparedAttrs state) group } + where + group = Env.uniqueNames names + add attrs name = Map.alter (Just . update) name attrs + update Nothing = AttrAccum [] [fragment] + update (Just old) = old { accumInits = fragment : accumInits old } + +addRestInitializer :: Rows.Fragment -> PrepareState -> PrepareState +addRestInitializer fragment state = state { preparedRest = fragment : preparedRest state } + +prepareConstructor :: Env.Env0 -> A.Suite -> PrepareState -> A.Decl -> Rows.RowResult PrepareState +prepareConstructor env classSuite state decl = do + self <- maybe (Rows.rowError "__init__ has no self parameter") return (A.selfPar decl) + let body = A.dbody decl + (_, prefixLength) = Types.scanInitPrefix env self classSuite body + indexed = zip [0..] body + prefix = take prefixLength indexed + uses = Map.fromListWith IntSet.union + [ (v, IntSet.singleton i) + | (i, stmt) <- indexed + , v <- Set.toList (Set.fromList (Names.free stmt)) + ] + writeOwners = Map.fromListWith Set.union + [ (i, Set.singleton attr) + | (i, stmt) <- prefix + , attr <- selfAttributes self stmt + ] + owners = foldr (ownDefinition uses) writeOwners prefix + groupIndices = Map.fromListWith IntSet.union + [ (attr, IntSet.singleton i) + | (i, attrs) <- Map.toList owners + , attr <- Set.toList attrs + ] + consumed = IntSet.unions (Map.elems groupIndices) + stmtByIndex = Map.fromList indexed + addGroup acc (attr, indices) = foldl' + (\acc' i -> addAttrInitializerGroup [attr] + (Rows.ConstructorFragment i (stmtByIndex Map.! i)) acc') + acc (IntSet.toAscList indices) + withAttrs = foldl' addGroup state (Map.toList groupIndices) + rest = + [ Rows.ConstructorFragment i stmt + | (i, stmt) <- indexed + , not (IntSet.member i consumed) + ] + return withAttrs + { preparedRest = reverse rest ++ preparedRest withAttrs + , preparedConstructor = Just decl { A.dbody = [] } + } + +ownDefinition :: Map.Map A.Name IntSet.IntSet + -> (Int, A.Stmt) + -> Map.Map Int (Set.Set A.Name) + -> Map.Map Int (Set.Set A.Name) +ownDefinition uses (i, A.Assign _ [A.PVar _ name _] _) owners + | not (IntSet.null usedAt) + , all (> i) (IntSet.toList usedAt) + , Just attrs <- foldM collect Set.empty (IntSet.toList usedAt) + = Map.insert i attrs owners + where + usedAt = Map.findWithDefault IntSet.empty name uses + collect attrs used = Set.union attrs <$> Map.lookup used owners +ownDefinition _ _ owners = owners + +selfAttributes :: A.Name -> A.Stmt -> [A.Name] +selfAttributes self stmt = Env.uniqueNames $ case stmt of + A.MutAssign _ (A.Dot _ (A.Var _ (A.NoQ receiver)) attr) _ + | receiver == self -> [attr] + A.AugAssign _ (A.Dot _ (A.Var _ (A.NoQ receiver)) attr) _ _ + | receiver == self -> [attr] + A.If _ branches elseSuite -> + concat [ concatMap (selfAttributes self) body | A.Branch _ body <- branches ] ++ + concatMap (selfAttributes self) elseSuite + A.While _ _ body elseSuite -> concatMap (selfAttributes self) (body ++ elseSuite) + A.For _ _ _ body elseSuite -> concatMap (selfAttributes self) (body ++ elseSuite) + A.Try _ body handlers elseSuite finallySuite -> + concatMap (selfAttributes self) body ++ + concat [ concatMap (selfAttributes self) hbody | A.Handler _ hbody <- handlers ] ++ + concatMap (selfAttributes self) (elseSuite ++ finallySuite) + A.With _ _ body -> concatMap (selfAttributes self) body + A.Data _ _ body -> concatMap (selfAttributes self) body + _ -> [] + +finishMembers :: ContainerKind -> PrepareState -> Map.Map Rows.MemberKey Rows.MemberContent +finishMembers kind state = Map.fromList (methods ++ attrs ++ initializers ++ rest) + where + methods = + [ (Rows.Method name, Rows.MethodContent decls) + | (name, decls) <- Map.toList (preparedMethods state) + ] + attrs = + [ ( Rows.Attr name + , Rows.AttrContent (reverse $ accumDecls attr) + ) + | (name, attr) <- Map.toList (preparedAttrs state) + ] + initializers = concat + [ entries name (reverse $ accumInits attr) + | (name,attr) <- Map.toList (preparedAttrs state) + ] + entries name fragments = + [ (Rows.StaticInit name, Rows.InitializerContent static) + | not (null static) + ] ++ + [ (Rows.InstanceInit name, Rows.InitializerContent instance') + | not (null instance') + ] + where + (static,instance') = partitionFragments fragments + partitionFragments fragments = case kind of + KClass{} -> partition isSuiteFragment fragments + KActor{} -> ([],fragments) + _ -> ([],[]) + isSuiteFragment Rows.SuiteFragment{} = True + isSuiteFragment _ = False + rest + | preparedConstructor state == Nothing && null (preparedRest state) = [] + | otherwise = + [ (Rows.InitRest, Rows.InitRestContent + (preparedConstructor state) + (reverse $ preparedRest state)) + ] + + +-- Preparation ------------------------------------------------------------------------------------------- + +-- Walk the typed module once and assign each dependency summary to the row +-- which stores that syntax. The row skeleton is only consulted to locate the +-- separately stored parts of a container; it is never reconstructed here. +prepareReachabilityRows :: Env.Env0 + -> I.TEnv + -> A.Module + -> Rows.InterfaceRows + -> Rows.RowResult ReachabilityRows +prepareReachabilityRows typeEnv sourceInterface typed@(A.Module mn _ _ suite) stored = do + when (Rows.rowModuleName stored /= mn) $ + Rows.rowError "module name does not match interface rows" + let suiteEnv = QuickType.envOfTopSuite suite + moduleEnv = Env.define suiteEnv (Env.setMod mn typeEnv) + globals = Set.fromList (topNames suite) + env0 = topReachEnv moduleEnv globals + extensions = Map.fromListWith (flip (++)) + [ (extensionTarget ext,[ext]) + | ext <- extensionInfos moduleEnv mn suite + ] + sourceInfo = Env.hnamesFrom sourceInterface + (prepared,_) <- foldM + (prepareTop moduleEnv sourceInfo stored extensions) + (emptyReachabilityRows, env0) + suite + let whole = force (wholeSummary env0 prepared) + typed `seq` whole `seq` return prepared{ reachWholeSummary = whole } + + +data ContainerPrepared = ContainerPrepared + { preparedKind :: ShapeKind + , preparedMembers :: Map.Map Rows.MemberKey Rows.MemberContent + , preparedMemberInfo :: Map.Map Rows.MemberKey MemberInfo + , preparedConstructorHeader :: Maybe ReachSummary + } + +prepareTop :: Env.Env0 + -> I.HTEnv + -> Rows.InterfaceRows + -> Map.Map TopKey [ExtensionInfo] + -> (ReachabilityRows, ReachEnv) + -> A.Stmt + -> Rows.RowResult (ReachabilityRows, ReachEnv) +prepareTop moduleEnv sourceInfo stored extensions (rows,env) stmt = do + let env' = advanceReachEnv (QuickType.envOf stmt) env + rows' <- case stmt of + A.Decl _ decls -> + foldM + (prepareTopDecl moduleEnv sourceInfo stored extensions + (advanceReachEnv (QuickType.envOf decls) env)) + rows + decls + _ -> + let owners = wholeStmtOwners stmt + summary = summarizeStmt env stmt + in if null owners + then return rows + { reachModuleSummary = reachModuleSummary rows <> summary } + else foldM (insertTopSummary Nothing summary) rows + [ TopKey (Rows.rowModuleName stored) name | name <- owners ] + return (rows',env') + +prepareTopDecl :: Env.Env0 + -> I.HTEnv + -> Rows.InterfaceRows + -> Map.Map TopKey [ExtensionInfo] + -> ReachEnv + -> ReachabilityRows + -> A.Decl + -> Rows.RowResult ReachabilityRows +prepareTopDecl moduleEnv sourceInfo stored extensions env rows decl + | not (isContainer decl) = + insertTopSummary Nothing (summarizeDecl env decl) rows owner + | otherwise = do + shape <- required ("missing container shape " ++ A.rawstr name) $ + Map.lookup name (Rows.rowShapes stored) + members <- required ("missing member rows " ++ A.rawstr name) $ + Map.lookup name (Rows.rowMembers stored) + let kind = containerKind sourceInfo decl + backendKind = backendContainerKind decl + (_,_,suite) = containerParts decl + (header,bodyEnv) = summarizeDeclHeader env decl + analysis <- analyzeContainer backendKind bodyEnv shape members suite + rows' <- insertTopSummary + (compactDeclaration $ Env.unalias (reachTypeEnv env) $ + Env.findQName (A.NoQ name) (reachTypeEnv env)) + (header <> analyzedResidual analysis) + rows + owner + prepareContainerMetadata moduleEnv stored extensions rows' + (owner,ContainerPrepared + kind + members + (analyzedMembers analysis) + (analyzedConstructorHeader analysis)) + where + name = Names.dname' decl + owner = TopKey (Rows.rowModuleName stored) name + + +-- Direct row analysis ----------------------------------------------------------------------------------- + +data SummaryPart = BodyPart | StaticInitPart | InstanceInitPart deriving Eq + +data HoleOwner = HoleOwner Rows.MemberKey SummaryPart + +data ConstructorContext = ConstructorContext + { constructorGuard :: ReachSummary + , constructorEnv :: ReachEnv + , constructorSelf :: Maybe A.Name + , constructorBody :: A.Suite + } + +data ContainerAnalysis = ContainerAnalysis + { analyzedResidual :: ReachSummary + , analyzedMembers :: Map.Map Rows.MemberKey MemberInfo + , analyzedConstructorHeader :: Maybe ReachSummary + } + +data Scan = Scan + { scanResidual :: ReachSummary + , scanMembers :: Map.Map Rows.MemberKey MemberInfo + , scanConstructor :: Maybe ConstructorContext + } + +emptyMemberInfo :: MemberInfo +emptyMemberInfo = MemberInfo mempty Nothing Nothing + +analyzeContainer :: ShapeKind + -> ReachEnv + -> Rows.ContainerShape + -> Map.Map Rows.MemberKey Rows.MemberContent + -> A.Suite + -> Rows.RowResult ContainerAnalysis +analyzeContainer kind env shape members suite = do + let suiteOwners = collectSuiteOwners members + constructorOwners = collectConstructorOwners members + initial = Scan mempty + (Map.fromSet (const emptyMemberInfo) $ logicalMembers members) + Nothing + scan <- analyzeSuite kind suiteOwners mempty env + (Rows.shapeSuite shape) suite initial + scan' <- analyzeConstructor constructorOwners (scanConstructor scan) scan + return ContainerAnalysis + { analyzedResidual = scanResidual scan' + , analyzedMembers = scanMembers scan' + , analyzedConstructorHeader = + constructorGuard <$> scanConstructor scan' + } + where + logicalMembers = Set.fromList . map logicalMember . Map.keys + logicalMember (Rows.StaticInit name) = Rows.Attr name + logicalMember (Rows.InstanceInit name) = Rows.Attr name + logicalMember member = member + +collectSuiteOwners :: Map.Map Rows.MemberKey Rows.MemberContent + -> Map.Map Int [HoleOwner] +collectSuiteOwners members = Map.fromListWith (++) $ + concatMap inMember (Map.toList members) + where + inMember (key,Rows.AttrContent declarations) = + [ (hole,[HoleOwner key BodyPart]) + | Rows.SuiteFragment hole _ <- declarations + ] + inMember (Rows.StaticInit name,Rows.InitializerContent initializers) = + [ (hole,[HoleOwner (Rows.Attr name) StaticInitPart]) + | Rows.SuiteFragment hole _ <- initializers + ] + inMember (Rows.InstanceInit name,Rows.InitializerContent initializers) = + [ (hole,[HoleOwner (Rows.Attr name) InstanceInitPart]) + | Rows.SuiteFragment hole _ <- initializers + ] + inMember (key,Rows.InitRestContent _ initializers) = + [ (hole,[HoleOwner key BodyPart]) + | Rows.SuiteFragment hole _ <- initializers + ] + inMember _ = [] + +collectConstructorOwners :: Map.Map Rows.MemberKey Rows.MemberContent + -> Map.Map Int [HoleOwner] +collectConstructorOwners members = Map.fromListWith (++) $ + concatMap inMember (Map.toList members) + where + inMember (Rows.InstanceInit name,Rows.InitializerContent initializers) = + [ (index,[HoleOwner (Rows.Attr name) InstanceInitPart]) + | Rows.ConstructorFragment index _ <- initializers + ] + inMember (key,Rows.InitRestContent _ initializers) = + [ (index,[HoleOwner key BodyPart]) + | Rows.ConstructorFragment index _ <- initializers + ] + inMember _ = [] + +analyzeSuite :: ShapeKind + -> Map.Map Int [HoleOwner] + -> ReachSummary + -> ReachEnv + -> Rows.SuiteShape + -> A.Suite + -> Scan + -> Rows.RowResult Scan +analyzeSuite kind owners guard env (Rows.SuiteShape shape) suite scan0 + | length shape /= length suite = Rows.rowError "container suite does not match row shape" + | otherwise = go env scan0 (zip shape suite) + where + go _ scan [] = return scan + go stmtEnv scan ((stored,stmt):rest) = do + scan' <- analyzeShapeStmt kind owners guard stmtEnv stored stmt scan + go (advanceReachEnv (QuickType.envOf stmt) stmtEnv) scan' rest + +analyzeShapeStmt :: ShapeKind + -> Map.Map Int [HoleOwner] + -> ReachSummary + -> ReachEnv + -> Rows.ShapeStmt + -> A.Stmt + -> Scan + -> Rows.RowResult Scan +analyzeShapeStmt _ _ guard env Rows.InlineStmt{} stmt scan = + return scan { scanResidual = scanResidual scan <> guard <> summarizeStmt env stmt } +analyzeShapeStmt kind owners guard env (Rows.HoleStmt hole) stmt scan = do + owned <- required ("missing suite fragment owner " ++ show hole) (Map.lookup hole owners) + let summary = guard <> summarizeStmt env stmt + part = if kind == ClassShape then StaticInitPart else InstanceInitPart + use (HoleOwner key BodyPart) = addMemberSummary key BodyPart summary + use (HoleOwner key _) = addMemberSummary key part summary + members' = foldl' (flip use) (scanMembers scan) owned + return scan { scanMembers = members' } +analyzeShapeStmt _ _ guard env (Rows.DeclStmt _ stored) (A.Decl _ decls) scan + | length stored /= length decls = Rows.rowError "container declarations do not match row shape" + | otherwise = foldM (analyzeDecl declEnv) scan (zip stored decls) + where + declEnv = advanceReachEnv (QuickType.envOf decls) env + analyzeDecl declEnv' acc (Rows.InlineDecl _,decl) = + return acc + { scanResidual = scanResidual acc <> guard <> summarizeDecl declEnv' decl } + analyzeDecl declEnv' acc (Rows.MethodDecl slot,decl) + | Rows.slotName slot /= A.dname decl = + Rows.rowError ("method row/name mismatch for " ++ A.rawstr (Rows.slotName slot)) + | otherwise = do + let (header,bodyEnv) = summarizeDeclHeader declEnv' decl + (stubHeader,_) = summarizeDeclHeader + declEnv'{ reachReflectiveOwner = False } + (Rows.methodHeader decl) + acc' = acc + { scanResidual = scanResidual acc <> guard <> stubHeader } + if Rows.slotIsConstructor slot + then case scanConstructor acc' of + Nothing -> return acc' + { scanConstructor = Just + (ConstructorContext (guard <> header) bodyEnv (A.selfPar decl) (A.dbody decl)) } + Just _ -> Rows.rowError "multiple constructor slots" + else return acc' + { scanMembers = addMemberSummary + (Rows.Method $ Rows.slotName slot) + BodyPart + (guard <> header <> summarizeSuite bodyEnv (A.dbody decl)) + (scanMembers acc') + } +analyzeShapeStmt kind owners guard env (Rows.IfStmt _ storedBranches elseShape) + (A.If _ branches elseSuite) scan + | length storedBranches /= length branches = Rows.rowError "container branches do not match row shape" + | otherwise = do + let conditions = [ summarizeCondition env condition | A.Branch condition _ <- branches ] + prefixes = tail (scanl (<>) mempty conditions) + scan1 <- foldM analyzeBranch scan (zip3 storedBranches branches prefixes) + analyzeSuite kind owners (guard <> foldMap id conditions) env + elseShape elseSuite scan1 + where + analyzeBranch acc ((_,storedBody),A.Branch _ body,prefix) = + analyzeSuite kind owners (guard <> prefix) env storedBody body acc +analyzeShapeStmt _ _ _ _ _ _ _ = Rows.rowError "container statement does not match row shape" + +addMemberSummary :: Rows.MemberKey + -> SummaryPart + -> ReachSummary + -> Map.Map Rows.MemberKey MemberInfo + -> Map.Map Rows.MemberKey MemberInfo +addMemberSummary key part summary = Map.alter (Just . add . maybe emptyMemberInfo id) key + where + add info = case part of + BodyPart -> info { memberSummary = memberSummary info <> summary } + StaticInitPart -> info + { memberStaticInitSummary = appendSummary summary (memberStaticInitSummary info) } + InstanceInitPart -> info + { memberInstanceInitSummary = appendSummary summary (memberInstanceInitSummary info) } + +appendSummary :: ReachSummary -> Maybe ReachSummary -> Maybe ReachSummary +appendSummary summary Nothing = Just summary +appendSummary summary (Just old) = Just (old <> summary) + +analyzeConstructor :: Map.Map Int [HoleOwner] + -> Maybe ConstructorContext + -> Scan + -> Rows.RowResult Scan +analyzeConstructor owners context scan + | Map.null owners = return scan + | otherwise = do + constructor <- required "constructor fragments have no constructor slot" context + snd <$> foldM (analyzeOne constructor) + (constructorEnv constructor,scan) + (zip [0..] $ constructorBody constructor) + where + analyzeOne constructor (env,acc) (index,stmt) = do + owned <- required ("missing constructor fragment owner " ++ show index) + (Map.lookup index owners) + let guard = constructorGuard constructor + raw = guard <> summarizeStmt env stmt + add members (HoleOwner key BodyPart) = + addMemberSummary key BodyPart raw members + add members (HoleOwner key InstanceInitPart) = + addMemberSummary key InstanceInitPart + (projectedSummary constructor env stmt key) members + add members (HoleOwner _ StaticInitPart) = members + members' = foldl' add (scanMembers acc) owned + return + ( advanceReachEnv (QuickType.envOf stmt) env + , acc { scanMembers = members' } + ) + + projectedSummary constructor env stmt (Rows.Attr name) = + case constructorSelf constructor >>= project of + Nothing -> mempty + Just projected -> constructorGuard constructor <> summarizeStmt env projected + where + project self = Rows.pruneConstructorInit self (Set.singleton name) stmt + projectedSummary _ _ _ _ = mempty + + +-- Member rows ------------------------------------------------------------------------------------------- + +prepareMemberRows :: TopKey + -> ContainerPrepared + -> ReachabilityRows + -> Rows.RowResult ReachabilityRows +prepareMemberRows owner prepared rows = + foldM add rows (Map.toAscList $ preparedMemberInfo prepared) + where + add acc (member,info) = insertMemberInfo owner member info acc + +-- Shape, slot, and reflection rows ---------------------------------------------------------------------- + +prepareContainerMetadata :: Env.Env0 + -> Rows.InterfaceRows + -> Map.Map TopKey [ExtensionInfo] + -> ReachabilityRows + -> (TopKey,ContainerPrepared) + -> Rows.RowResult ReachabilityRows +prepareContainerMetadata env stored extensions rows (owner,prepared) = do + rows1 <- prepareMemberRows owner prepared rows + let targetExtensions = Map.findWithDefault [] owner extensions + slots <- effectiveSlots env (topModule owner) stored targetExtensions owner + let abstracts = Set.toAscList $ Set.fromList + [ ref | (ref,SlotInfo _ AbstractSlot) <- Map.toList slots ] + reflectable = Set.toAscList $ Set.fromList + [ name + | (AttrRef name,SlotInfo provider AttributeSlot) <- Map.toList slots + , provider == owner + , not (Names.isWitness name) + , reflectableProperty kind stored owner name + ] + kind = preparedKind prepared + constructors = constructorInfo env kind owner prepared (constructorObligations kind owner slots) + shape = ShapeInfo owner kind + (shapeLineageFor env targetExtensions owner) + constructors abstracts + rows2 <- insertTopSummary Nothing (inheritedValueObligations env owner) rows1 owner + rows3 <- insertShapeInfo owner shape rows2 + rows4 <- foldM (insertSlotInfo owner) rows3 (Map.toAscList slots) + insertReflectable owner (ReflectableAttrs reflectable) rows4 + +reflectableProperty :: ShapeKind + -> Rows.InterfaceRows + -> TopKey + -> A.Name + -> Bool +reflectableProperty kind stored owner name = case content of + Just (Rows.AttrContent declarations) -> + not (null declarations) || + kind == ActorShape || + any constructorInitializer initializers + _ -> False + where + content = Map.lookup (topName owner) (Rows.rowMembers stored) >>= + Map.lookup (Rows.Attr name) + initializers = case Map.lookup (topName owner) (Rows.rowMembers stored) >>= + Map.lookup (Rows.InstanceInit name) of + Just (Rows.InitializerContent fragments) -> fragments + _ -> [] + constructorInitializer Rows.ConstructorFragment{} = True + constructorInitializer Rows.SuiteFragment{} = False + + +data ExtensionInfo = ExtensionInfo + { extensionOwner :: TopKey + , extensionTarget :: TopKey + , extensionProtocols :: [TopKey] + , extensionMembers :: I.TEnv + } + +extensionInfos :: Env.Env0 -> A.ModName -> A.Suite -> [ExtensionInfo] +extensionInfos env mn suite = + [ make decl + | A.Decl _ decls <- suite + , decl@A.Extension{} <- decls + ] + where + make decl = case Env.findQName (A.NoQ name) env of + I.NExt _ target protocols members _ _ -> ExtensionInfo + (TopKey mn name) + (topKey env $ A.tcname target) + (stableTopKeys [ topKey env $ A.tcname p | (_,p) <- protocols ]) + members + info -> error ("Acton.Reachability: extension info expected for " ++ show name ++ ", got " ++ show info) + where name = Names.dname' decl + +effectiveSlots :: Env.Env0 + -> A.ModName + -> Rows.InterfaceRows + -> [ExtensionInfo] + -> TopKey + -> Rows.RowResult (Map.Map MemberRef SlotInfo) +effectiveSlots env mn stored extensions owner = do + direct <- directSlots env owner + let viaExtensions = foldl' addExtension Map.empty extensions + physical = directPhysicalSlots mn stored owner + concrete = addConcrete viaExtensions $ addConcrete physical direct + return concrete + where + -- The type environment may expose an inherited protocol signature before + -- the concrete declaration that implements it. Concrete class/actor + -- members win first; an extension fills a genuinely missing or abstract + -- slot, but never replaces an already concrete provider. + addConcrete additions slots0 = Map.foldlWithKey' add slots0 additions + where + add slots ref info = case Map.lookup ref slots of + Nothing -> Map.insert ref info slots + Just (SlotInfo _ AbstractSlot) -> Map.insert ref info slots + Just _ -> slots + + addExtension slots ext = foldl' (addMember $ extensionOwner ext) slots (effectiveTEnv $ extensionMembers ext) + addMember provider slots (name,info) = + case infoMemberRef info name of + Nothing -> slots + Just ref + | isConstructorRef ref -> slots + | otherwise -> Map.insert ref (SlotInfo provider $ slotForInfo env provider ref info) slots + +directSlots :: Env.Env0 + -> TopKey + -> Rows.RowResult (Map.Map MemberRef SlotInfo) +directSlots env owner = foldM add Map.empty names + where + qn = topQName owner + ancestry = (qn,directEnv) : + [ (A.tcname con,te) + | (_,con) <- inherited + , let (_,_,te) = Env.findConName (A.tcname con) env + ] + (_,inherited,directEnv) = Env.findConName qn env + names = Env.uniqueNames [ n | (_,te) <- ancestry, (n,_) <- te ] + + add slots name = case firstProvider name ancestry of + Nothing -> Rows.rowError ("missing effective provider for " ++ A.rawstr name) + Just (providerQName,info) -> case infoMemberRef info name of + Nothing -> return slots + Just ref | isConstructorRef ref -> return slots + Just ref -> do + let provider = topKey env providerQName + return $ Map.insert ref (SlotInfo provider $ slotForInfo env provider ref info) slots + +directPhysicalSlots :: A.ModName + -> Rows.InterfaceRows + -> TopKey + -> Map.Map MemberRef SlotInfo +directPhysicalSlots mn stored owner + | topModule owner /= mn = Map.empty + | otherwise = case Map.lookup (topName owner) (Rows.rowMembers stored) of + Nothing -> Map.empty + Just members -> Map.fromList + [ (ref,SlotInfo owner slot) + | member <- Map.keys members + , Just (ref,slot) <- [physical member] + ] + where + physical (Rows.Method n) + | n == Builtin.initKW = Nothing + | otherwise = Just (MethodRef n,physicalMethod n) + physical (Rows.Attr n) = Just (AttrRef n,physicalAttr) + physical Rows.StaticInit{} = Nothing + physical Rows.InstanceInit{} = Nothing + physical Rows.InitRest = Nothing + + physicalMethod n + | topModule owner == Builtin.mBuiltin = OpaqueSlot + | otherwise = StoredSlot (Rows.Method n) + physicalAttr + | topModule owner == Builtin.mBuiltin = OpaqueSlot + | otherwise = AttributeSlot + +slotForInfo :: Env.Env0 -> TopKey -> MemberRef -> I.NameInfo -> SlotDecl +slotForInfo _ provider _ _ | topModule provider == Builtin.mBuiltin = OpaqueSlot +slotForInfo _ _ (MethodRef n) info = case info of + I.NSig{} -> AbstractSlot + I.NDef{} -> StoredSlot (Rows.Method n) + _ -> error ("Acton.Reachability: method info expected, got " ++ show info) +slotForInfo env provider (AttrRef _) info = case info of + I.NSig{} + | concretePropertyOwner -> AttributeSlot + | otherwise -> AbstractSlot + I.NVar{} -> AttributeSlot + I.NSVar{} -> AttributeSlot + _ -> error ("Acton.Reachability: attribute info expected, got " ++ show info) + where + concretePropertyOwner = case Env.findQName (topQName provider) env of + I.NClass{} -> True + I.NAct{} -> True + _ -> False + +containerTCon :: Env.Env0 -> TopKey -> A.TCon +containerTCon env owner = A.TC qn (map A.tVar $ A.qbound q) + where qn = case Env.thismod env of + Just mn | mn == topModule owner -> A.NoQ (topName owner) + _ -> topQName owner + (q,_,_) = Env.findConName qn env + +constructorInfo :: Env.Env0 + -> ShapeKind + -> TopKey + -> ContainerPrepared + -> ReachSummary + -> Maybe (TopKey,ConstructorDecl) +constructorInfo env kind owner prepared generated = case kind of + ProtocolShape + | hasInitRest -> Just (owner,StoredConstructor summary) + | otherwise -> Nothing + _ | topModule owner == Builtin.mBuiltin -> Just (owner,OpaqueConstructor) + _ | hasInitRest -> Just (owner,StoredConstructor summary) + WitnessShape -> Just (owner,GeneratedConstructor summary) + _ + | Just provider <- inheritedProvider + -> Just (provider,InheritedConstructor generated) + | otherwise -> Just (owner,GeneratedConstructor summary) + where + hasInitRest = Map.member Rows.InitRest (preparedMembers prepared) + header = maybe mempty id (preparedConstructorHeader prepared) + summary = header <> generated + (_,inherited,_) = Env.findConName (topQName owner) env + inheritedProvider = firstConcreteAncestor env inherited + +-- Runtime value conversion and C-only iterable consumers can invoke these +-- slots after the typed tree has been summarized. Retaining them on a +-- constructed receiver keeps that hidden runtime surface explicit and +-- bounded; ordinary source calls remain exact member edges. +constructorObligations :: ShapeKind -> TopKey -> Map.Map MemberRef SlotInfo -> ReachSummary +constructorObligations kind owner slots = reachSummaryFromEdges + [ directEdge owner ref + | (ref@(MethodRef name),SlotInfo _ slot) <- Map.toAscList slots + , slot /= AbstractSlot + , name == Names.altInit || + name `elem` (Builtin.nextKW : Builtin.valueKWs) || + kind == ActorShape && name == Builtin.cleanupKW + ] + +-- CodeGen initializes inherited NVar entries in every emitted class table, +-- even when no source expression reads the value. Keep those exact provider +-- slots with the container top. NSig properties are instance layout and are +-- deliberately not part of this class-table obligation. Internal witness +-- bindings are normalized into globals, locals, parameters, or instance +-- properties and never occupy class-table slots. +inheritedValueObligations :: Env.Env0 -> TopKey -> ReachSummary +inheritedValueObligations env owner = reachSummaryFromEdges + [ directEdge owner (AttrRef name) + | (provider,name) <- Env.inheritedAttrs env (topQName owner) + , not (Names.isWitness name) + , Just I.NVar{} <- [Env.findAttrInfo' env provider name] + ] + +directEdge :: TopKey -> MemberRef -> ReachEdge +directEdge (TopKey mn name) = Direct mn name + +shapeLineageFor :: Env.Env0 -> [ExtensionInfo] -> TopKey -> [TopKey] +shapeLineageFor env extensions owner = stableTopKeys (owner : inherited ++ protocols) + where + (_,bases,_) = Env.findConName (topQName owner) env + inherited = [ topKey env $ A.tcname con | (_,con) <- bases ] + protocols = concatMap extensionProtocols extensions + +-- Protocols and extensions have already become backend classes in the typed +-- tree. Their source interface entry is the remaining semantic provenance; +-- generated sibling classes have no source entry and retain their backend +-- class kind. +containerKind :: I.HTEnv -> A.Decl -> ShapeKind +containerKind sourceInfo decl = case HashMap.lookup (Names.dname' decl) sourceInfo of + Just I.NAct{} -> ActorShape + Just I.NClass{} -> ClassShape + Just I.NProto{} -> ProtocolShape + Just I.NExt{} -> WitnessShape + Just info -> error ("Acton.Reachability: container interface expected, got " ++ show info) + Nothing -> backendContainerKind decl + +backendContainerKind :: A.Decl -> ShapeKind +backendContainerKind A.Actor{} = ActorShape +backendContainerKind A.Class{} = ClassShape +backendContainerKind A.Protocol{} = ProtocolShape +backendContainerKind A.Extension{} = WitnessShape +backendContainerKind decl = error ("Acton.Reachability: container expected, got " ++ show decl) + + +-- Utilities --------------------------------------------------------------------------------------------- + +topNames :: A.Suite -> [A.Name] +topNames = Env.uniqueNames . concatMap stmtNames + +stmtNames :: A.Stmt -> [A.Name] +stmtNames (A.Decl _ decls) = map Names.dname' decls +stmtNames stmt = wholeStmtOwners stmt + +wholeStmtOwners :: A.Stmt -> [A.Name] +wholeStmtOwners = Env.uniqueNames . map fst . QuickType.envOf + +topKey :: Env.Env0 -> A.QName -> TopKey +topKey env qn = case Env.unalias env qn of + A.GName mn n -> TopKey mn n + A.QName mn n -> TopKey mn n + A.NoQ n -> case Env.thismod env of + Just mn -> TopKey mn n + Nothing -> error ("Acton.Reachability: unscoped name " ++ A.rawstr n) + +topQName :: TopKey -> A.QName +topQName (TopKey mn n) = A.GName mn n + +topModule :: TopKey -> A.ModName +topModule (TopKey mn _) = mn + +topName :: TopKey -> A.Name +topName (TopKey _ n) = n + +effectiveTEnv :: I.TEnv -> I.TEnv +effectiveTEnv te = + [ (n,info) + | n <- Env.uniqueNames (map fst te) + , Just info <- [Env.findAttrInfoIn n te] + ] + +firstProvider :: A.Name -> [(A.QName,I.TEnv)] -> Maybe (A.QName,I.NameInfo) +firstProvider _ [] = Nothing +firstProvider name ((provider,te):rest) = case Env.findAttrInfoIn name te of + Just info -> Just (provider,info) + Nothing -> firstProvider name rest + +firstConcreteAncestor :: Env.Env0 -> [(I.WPath,A.TCon)] -> Maybe TopKey +firstConcreteAncestor _ [] = Nothing +firstConcreteAncestor env ((_,con):rest) = case Env.findQName name env of + I.NClass{} -> Just (topKey env name) + I.NAct{} -> Just (topKey env name) + _ -> firstConcreteAncestor env rest + where name = A.tcname con + +infoMemberRef :: I.NameInfo -> A.Name -> Maybe MemberRef +infoMemberRef info name = case info of + I.NDef{} -> Just (MethodRef name) + I.NSig schema deco _ + | deco == A.Property -> Just (AttrRef name) + | A.TFun{} <- A.sctype schema + -> Just (MethodRef name) + | otherwise -> Nothing + I.NVar{} -> Just (AttrRef name) + I.NSVar{} -> Just (AttrRef name) + _ -> Nothing + +isConstructorRef :: MemberRef -> Bool +isConstructorRef (MethodRef name) = name == Builtin.initKW +isConstructorRef _ = False + +nonEmptySummary :: [ReachSummary] -> Maybe ReachSummary +nonEmptySummary [] = Nothing +nonEmptySummary summaries = Just (foldMap id summaries) + +-- A whole-surface module can call selective providers from any emitted body. +-- Persist one compact aggregate so a whole boundary contributes exact +-- provider interest without forcing those providers whole as well. +wholeSummary :: ReachEnv -> ReachabilityRows -> ReachSummary +wholeSummary env rows = + reachModuleSummary rows <> + foldMap topSummary (Map.elems $ reachTopRows rows) <> + foldMap memberInfoSummary (Map.elems $ reachMemberRows rows) <> + foldMap shapeInfoSummary (Map.elems $ reachShapeRows rows) <> + inheritedPropertyLayoutSummary <> + foldMap propertyTypeSummary (Map.keys $ reachShapeRows rows) + where + topSummary (LocalTop _ summary) = summary + topSummary (OpaqueTop summary) = summary + + memberInfoSummary info = + memberSummary info <> + maybe mempty id (memberStaticInitSummary info) <> + maybe mempty id (memberInstanceInitSummary info) + + shapeInfoSummary = maybe mempty (constructorSummary . snd) . shapeConstructor + constructorSummary constructor = case constructor of + StoredConstructor summary -> summary + GeneratedConstructor summary -> summary + InheritedConstructor summary -> summary + OpaqueConstructor -> mempty + + -- A whole consumer keeps its complete inherited instance layout. Retain + -- every ancestor property declaration, including one shadowed by a local + -- redeclaration, so selectively generated ancestors keep the same prefix. + inheritedPropertyLayoutSummary = reachSummaryFromEdges + [ DeclareAttr (topModule ancestor) (topName ancestor) name + | ((receiver,AttrRef name),SlotInfo _ AttributeSlot) <- + Map.toAscList (reachSlotRows rows) + , Just shape <- [Map.lookup receiver (reachShapeRows rows)] + , ancestor <- drop 1 (shapeLineage shape) + , declaresProperty ancestor name + ] + + declaresProperty owner name = case Env.findQName (topQName owner) typeEnv of + I.NClass _ _ members _ -> property members + I.NAct _ _ _ members _ -> property members + _ -> False + where + property members = case lookup name members of + Just (I.NSig _ A.Property _) -> True + _ -> False + typeEnv = reachTypeEnv env + + -- Whole CodeGen emits every effective instance-property field in each + -- class header, including inherited properties, whether or not the class + -- is constructed. Their representation types therefore belong to the + -- whole-module contract, but not to a selectively projected class top. + propertyTypeSummary owner = foldMap propertyType + (Env.fullAttrEnv (reachTypeEnv env) $ + containerTCon (reachTypeEnv env) owner) + propertyType (_,I.NSig schema A.Property _) = + summarizeType env (A.sctype schema) + propertyType _ = mempty + +stableTopKeys :: [TopKey] -> [TopKey] +stableTopKeys = go Set.empty + where + go _ [] = [] + go seen (key:keys) + | Set.member key seen = go seen keys + | otherwise = key : go (Set.insert key seen) keys + +compactDeclaration :: I.NameInfo -> Maybe I.NameInfo +compactDeclaration info = case info of + I.NClass q bases _ doc -> Just (I.NClass q bases [] doc) + I.NProto q bases _ doc -> Just (I.NProto q bases [] doc) + I.NAct q pos kwd _ doc -> Just (I.NAct q pos kwd [] doc) + I.NExt q target bases _ opts doc -> Just (I.NExt q target bases [] opts doc) + _ -> error + ("Acton.Reachability: container declaration expected, got " ++ show info) + +insertTopSummary :: Maybe I.NameInfo + -> ReachSummary + -> ReachabilityRows + -> TopKey + -> Rows.RowResult ReachabilityRows +insertTopSummary declaration summary rows key = do + let info + | topModule key == Builtin.mBuiltin = OpaqueTop summary + | otherwise = LocalTop declaration summary + tops <- case Map.lookup key (reachTopRows rows) of + Nothing -> return $ Map.insert key (force info) (reachTopRows rows) + Just previous -> do + merged <- mergeTopInfo key previous info + return $ Map.insert key (force merged) (reachTopRows rows) + return rows{ reachTopRows = tops } + +mergeTopInfo :: TopKey -> TopInfo -> TopInfo -> Rows.RowResult TopInfo +mergeTopInfo _ (OpaqueTop summary) (OpaqueTop summary') = + return (OpaqueTop $ summary <> summary') +mergeTopInfo key (LocalTop declaration summary) (LocalTop declaration' summary') = + case (declaration,declaration') of + (Just _,Just _) -> Rows.rowError ("duplicate container reach row " ++ show key) + _ -> return $ LocalTop (pick declaration declaration') (summary <> summary') + where + pick (Just info) _ = Just info + pick Nothing info = info +mergeTopInfo key _ _ = Rows.rowError ("inconsistent top reach row " ++ show key) + +insertMemberInfo :: TopKey -> Rows.MemberKey -> MemberInfo -> ReachabilityRows -> Rows.RowResult ReachabilityRows +insertMemberInfo owner member info rows = do + members <- insertUnique (owner,member) (force info) (reachMemberRows rows) + ("duplicate member reach row " ++ show (owner,member)) + return rows{ reachMemberRows = members } + +insertShapeInfo :: TopKey -> ShapeInfo -> ReachabilityRows -> Rows.RowResult ReachabilityRows +insertShapeInfo owner info rows = do + shapes <- insertUnique owner (force info) (reachShapeRows rows) ("duplicate shape reach row " ++ show owner) + return rows{ reachShapeRows = shapes } + +insertSlotInfo :: TopKey -> ReachabilityRows -> (MemberRef,SlotInfo) -> Rows.RowResult ReachabilityRows +insertSlotInfo receiver rows (ref,info) = do + slots <- insertUnique (receiver,ref) (force info) (reachSlotRows rows) + ("duplicate slot reach row " ++ show (receiver,ref)) + return rows{ reachSlotRows = slots } + +insertReflectable :: TopKey -> ReflectableAttrs -> ReachabilityRows -> Rows.RowResult ReachabilityRows +insertReflectable receiver attrs rows = do + reflected <- insertUnique receiver (force attrs) (reachReflectableRows rows) + ("duplicate reflectable reach row " ++ show receiver) + return rows{ reachReflectableRows = reflected } + +insertUnique :: Ord k => k -> a -> Map.Map k a -> String -> Rows.RowResult (Map.Map k a) +insertUnique key value values msg + | Map.member key values = Rows.rowError msg + | otherwise = return (Map.insert key value values) + +required :: String -> Maybe a -> Rows.RowResult a +required msg = maybe (Rows.rowError msg) return + +foldMapM :: (Monoid b, Monad m) => (a -> m b) -> [a] -> m b +foldMapM f = foldM (\acc item -> (acc <>) <$> f item) mempty + + +-- Selection --------------------------------------------------------------------------------------------- + +-- | On-demand access to persisted reachability rows. 'selectProgram' +-- memoizes every exact-key result for the duration of one run. +data ReachLookup m = ReachLookup + { lookupTopRow :: TopKey -> m (Maybe TopInfo) + , lookupMemberRow :: TopKey -> Rows.MemberKey -> m (Maybe MemberInfo) + , lookupShapeRow :: TopKey -> m (Maybe ShapeInfo) + , lookupSlotRow :: TopKey -> MemberRef -> m (Maybe SlotInfo) + , lookupSurfaceSlots :: TopKey -> m [(MemberRef, SlotInfo)] + , lookupReflectableAttrs :: TopKey -> m (Maybe ReflectableAttrs) + } + +data SelectedRow + = TopRow TopKey + | OpaqueTopRow TopKey + | MemberRow TopKey Rows.MemberKey + | AttrRow TopKey A.Name + | StaticInitRow TopKey A.Name + | InstanceInitRow TopKey A.Name + | GeneratedRow TopKey MemberRef + deriving (Eq,Ord,Show) + +-- The result is a set of exact persisted or generated rows, plus the two +-- runtime facts needed while closing dispatch and initialization. +data Selection = Selection + { selectedDeclarations :: Set.Set TopKey + , selectedRows :: Set.Set SelectedRow + , selectedConstructed :: Set.Set TopKey + , selectedInitialized :: Set.Set TopKey + } deriving (Eq,Show) + +emptySelection :: Selection +emptySelection = Selection Set.empty Set.empty Set.empty Set.empty + +selectedTops :: Selection -> Set.Set TopKey +selectedTops = selectKeys top . selectedRows + where + top (TopRow key) = Just key + top _ = Nothing + +selectedOpaqueTops :: Selection -> Set.Set TopKey +selectedOpaqueTops = selectKeys top . selectedRows + where + top (OpaqueTopRow key) = Just key + top _ = Nothing + +selectedMembers :: Selection -> Set.Set (TopKey,Rows.MemberKey) +selectedMembers = selectKeys member . selectedRows + where + member (MemberRow owner name) = Just (owner,name) + member _ = Nothing + +selectedAttrs :: Selection -> Set.Set (TopKey,A.Name) +selectedAttrs = selectKeys attr . selectedRows + where + attr (AttrRow owner name) = Just (owner,name) + attr _ = Nothing + +selectedStaticInitializers :: Selection -> Set.Set (TopKey,A.Name) +selectedStaticInitializers = selectKeys initializer . selectedRows + where + initializer (StaticInitRow owner name) = Just (owner,name) + initializer _ = Nothing + +selectedInstanceInitializers :: Selection -> Set.Set (TopKey,A.Name) +selectedInstanceInitializers = selectKeys initializer . selectedRows + where + initializer (InstanceInitRow owner name) = Just (owner,name) + initializer _ = Nothing + +selectedGenerated :: Selection -> Set.Set (TopKey,MemberRef) +selectedGenerated = selectKeys generated . selectedRows + where + generated (GeneratedRow owner member) = Just (owner,member) + generated _ = Nothing + +selectKeys :: Ord a => (SelectedRow -> Maybe a) -> Set.Set SelectedRow -> Set.Set a +selectKeys project = Set.fromList . mapMaybe project . Set.toAscList + +-- Errors ------------------------------------------------------------------------------------------------ + +data SelectionError + = MissingTop TopKey + | MissingShape TopKey + | InvalidLineage TopKey [TopKey] + | MissingMemberSummary TopKey Rows.MemberKey + | MissingSlot TopKey MemberRef + | MissingReflectableAttrs TopKey + | InvalidStoredSlot TopKey MemberRef Rows.MemberKey + | InvalidSlotKind TopKey MemberRef SlotDecl + | AbstractMemberSelected TopKey MemberRef TopKey + | AbstractClassConstructed TopKey [MemberRef] + | ProtocolConstructed TopKey + | MissingConstructor TopKey + | DynamicSerializationRequiresWhole + deriving (Eq, Show) + + +-- Worklist ---------------------------------------------------------------------------------------------- + +type SelectM m = ExceptT SelectionError (StateT LookupCache m) + +data LookupCache = LookupCache + { cachedTops :: Map.Map TopKey (Maybe TopInfo) + , cachedMembers :: Map.Map (TopKey,Rows.MemberKey) (Maybe MemberInfo) + , cachedShapes :: Map.Map TopKey (Maybe ShapeInfo) + , cachedSlots :: Map.Map (TopKey,MemberRef) (Maybe SlotInfo) + , cachedSurfaces :: Map.Map TopKey [(MemberRef,SlotInfo)] + , cachedReflections :: Map.Map TopKey (Maybe ReflectableAttrs) + } + +emptyLookupCache :: LookupCache +emptyLookupCache = LookupCache Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty + +cachedLookup :: (Monad m, Ord key) + => (LookupCache -> Map.Map key value) + -> (Map.Map key value -> LookupCache -> LookupCache) + -> (key -> m value) + -> key + -> SelectM m value +cachedLookup field replace readValue key = do + cache <- lift get + case Map.lookup key (field cache) of + Just value -> return value + Nothing -> do + value <- lift (lift $ readValue key) + lift $ modify' (replace $ Map.insert key value (field cache)) + return value + +loadTopRow :: Monad m => ReachLookup m -> TopKey -> SelectM m (Maybe TopInfo) +loadTopRow lookups = cachedLookup cachedTops set (lookupTopRow lookups) + where set rows cache = cache{cachedTops=rows} + +loadMemberRow :: Monad m + => ReachLookup m + -> TopKey + -> Rows.MemberKey + -> SelectM m (Maybe MemberInfo) +loadMemberRow lookups owner member = cachedLookup cachedMembers set readOne (owner,member) + where + set rows cache = cache{cachedMembers=rows} + readOne (key,row) = lookupMemberRow lookups key row + +loadShapeRow :: Monad m => ReachLookup m -> TopKey -> SelectM m (Maybe ShapeInfo) +loadShapeRow lookups = cachedLookup cachedShapes set (lookupShapeRow lookups) + where set rows cache = cache{cachedShapes=rows} + +loadSlotRow :: Monad m + => ReachLookup m + -> TopKey + -> MemberRef + -> SelectM m (Maybe SlotInfo) +loadSlotRow lookups owner member = cachedLookup cachedSlots set readOne (owner,member) + where + set rows cache = cache{cachedSlots=rows} + readOne (key,row) = lookupSlotRow lookups key row + +loadSurfaceSlots :: Monad m + => ReachLookup m + -> TopKey + -> SelectM m [(MemberRef,SlotInfo)] +loadSurfaceSlots lookups = cachedLookup cachedSurfaces set (lookupSurfaceSlots lookups) + where set rows cache = cache{cachedSurfaces=rows} + +loadReflectableAttrs :: Monad m + => ReachLookup m + -> TopKey + -> SelectM m (Maybe ReflectableAttrs) +loadReflectableAttrs lookups = cachedLookup cachedReflections set (lookupReflectableAttrs lookups) + where set rows cache = cache{cachedReflections=rows} + +data WorkItem + = ReachWork ReachEdge + | InitializeWork TopKey + | ReflectWork TopKey TopKey + deriving (Eq, Ord, Show) + +data Work = Work + { workQueue :: Seq.Seq WorkItem + , workNeeded :: Set.Set TopKey + , workDeclarations :: Set.Set TopKey + , workRows :: Set.Set SelectedRow + , workConstructed :: Set.Set TopKey + , workInitialized :: Set.Set TopKey + , workDispatches :: Set.Set (TopKey,MemberRef) + , workReflections :: Set.Set TopKey + , workDispatchPairs :: Set.Set (TopKey,MemberRef,TopKey) + , workReflectionPairs :: Set.Set (TopKey,TopKey) + } + +emptyWork :: [ReachEdge] -> Work +emptyWork seeds = Work + { workQueue = Seq.fromList (map ReachWork seeds) + , workNeeded = Set.empty + , workDeclarations = Set.empty + , workRows = Set.empty + , workConstructed = Set.empty + , workInitialized = Set.empty + , workDispatches = Set.empty + , workReflections = Set.empty + , workDispatchPairs = Set.empty + , workReflectionPairs = Set.empty + } + +finish :: Work -> Selection +finish work = Selection + { selectedDeclarations = workDeclarations work + , selectedRows = workRows work + , selectedConstructed = workConstructed work + , selectedInitialized = workInitialized work + } + +hasRow :: SelectedRow -> Work -> Bool +hasRow row = Set.member row . workRows + +keepRow :: SelectedRow -> Work -> Work +keepRow row work = work { workRows = Set.insert row (workRows work) } + +selectedWorkAttrs :: Work -> [(TopKey,A.Name)] +selectedWorkAttrs work = + [ (owner,name) + | AttrRow owner name <- Set.toAscList (workRows work) + ] + +selectProgram :: Monad m => ReachLookup m -> [ReachEdge] -> m (Either SelectionError Selection) +selectProgram lookups seeds = fmap fst $ + runStateT (runExceptT $ finish <$> drain lookups (emptyWork seeds)) emptyLookupCache + +drain :: Monad m => ReachLookup m -> Work -> SelectM m Work +drain lookups work = + case Seq.viewl (workQueue work) of + Seq.EmptyL -> return work + item Seq.:< rest -> do + work' <- process lookups item work{ workQueue = rest } + drain lookups work' + +process :: Monad m => ReachLookup m -> WorkItem -> Work -> SelectM m Work +process lookups item work = + case item of + ReachWork edge -> processEdge lookups edge work + InitializeWork receiver -> initializeReceiver lookups receiver work + ReflectWork receiver concrete -> reflectConcrete lookups receiver concrete work + +processEdge :: Monad m => ReachLookup m -> ReachEdge -> Work -> SelectM m Work +processEdge lookups edge work = + case edge of + Declare mn n -> return (declareTop (TopKey mn n) work) + Need mn n -> selectTop lookups (TopKey mn n) work + Construct mn n -> constructShape lookups (TopKey mn n) work + Direct mn n ref -> directMember lookups (TopKey mn n) ref work + Dispatch mn n ref -> dispatchMember lookups (TopKey mn n) ref work + Reflect mn n -> reflectShape lookups (TopKey mn n) work + DynamicSerialization -> throwE DynamicSerializationRequiresWhole + DeclareAttr mn n attr -> declareAttribute lookups (TopKey mn n) attr work + + +-- Top-level and shape lookups ----------------------------------------------------------------------------- + +lookupTop :: Monad m => ReachLookup m -> TopKey -> SelectM m TopInfo +lookupTop lookups key = do + mTop <- loadTopRow lookups key + case mTop of + Nothing -> throwE (MissingTop key) + Just top -> return top + +lookupShape :: Monad m => ReachLookup m -> TopKey -> SelectM m ShapeInfo +lookupShape lookups key = do + mShape <- loadShapeRow lookups key + case mShape of + Nothing -> throwE (MissingShape key) + Just shape -> return shape + +selectTop :: Monad m => ReachLookup m -> TopKey -> Work -> SelectM m Work +selectTop lookups key work + | Set.member key (workNeeded work) = return work + | otherwise = do + top <- lookupTop lookups key + let work0 = work + { workNeeded = Set.insert key (workNeeded work) + , workDeclarations = Set.delete key (workDeclarations work) + } + case top of + OpaqueTop summary -> + return (enqueueSummary summary $ keepRow (OpaqueTopRow key) work0) + LocalTop header summary -> do + let work1 = enqueueSummary summary (keepRow (TopRow key) work0) + case header of + Nothing -> return work1 + Just _ -> do + shape <- lookupShape lookups key + case shapeLineage shape of + owner : inherited + | owner == key -> return $ foldl (flip enqueueNeed) work1 inherited + lineage -> throwE (InvalidLineage key lineage) + +enqueueNeed :: TopKey -> Work -> Work +enqueueNeed (TopKey mn n) = enqueueReach (Need mn n) + +declareTop :: TopKey -> Work -> Work +declareTop key work + | Set.member key (workNeeded work) = work + | otherwise = work + { workDeclarations = Set.insert key (workDeclarations work) } + + +-- Members ------------------------------------------------------------------------------------------------ + +lookupMemberInfo :: Monad m => ReachLookup m -> TopKey -> Rows.MemberKey -> SelectM m MemberInfo +lookupMemberInfo lookups owner member = do + mInfo <- loadMemberRow lookups owner member + case mInfo of + Nothing -> throwE (MissingMemberSummary owner member) + Just info -> return info + +lookupMemberInfoMaybe :: Monad m => ReachLookup m -> TopKey -> Rows.MemberKey -> SelectM m (Maybe MemberInfo) +lookupMemberInfoMaybe = loadMemberRow + +selectMember :: Monad m => ReachLookup m -> TopKey -> Rows.MemberKey -> Work -> SelectM m Work +selectMember lookups owner member work + | hasRow row work = return work + | otherwise = do + work0 <- selectTop lookups owner work + info <- lookupMemberInfo lookups owner member + return (enqueueSummary (memberSummary info) $ keepRow row work0) + where row = MemberRow owner member + +-- Retain an instance-property declaration for layout without retaining its +-- prunable constructor-prefix initialization. This is distinct from reading +-- the attribute, which enters through Direct and selects both obligations. +declareAttribute :: Monad m + => ReachLookup m + -> TopKey + -> A.Name + -> Work + -> SelectM m Work +declareAttribute lookups receiver name work = do + let ref = AttrRef name + work0 <- selectTop lookups receiver work + (owner, slot) <- resolveSlot lookups receiver ref + case slot of + AttributeSlot -> selectMember lookups owner (Rows.Attr name) work0 + _ -> throwE (InvalidSlotKind owner ref slot) + +directMember :: Monad m => ReachLookup m -> TopKey -> MemberRef -> Work -> SelectM m Work +directMember lookups receiver ref work = do + work0 <- selectTop lookups receiver work + case ref of + MethodRef n | n == Builtin.initKW -> + return (enqueue (InitializeWork receiver) work0) + _ -> do + (owner, slot) <- resolveSlot lookups receiver ref + selectSlot lookups receiver owner ref slot work0 + +selectSlot :: Monad m => ReachLookup m -> TopKey -> TopKey -> MemberRef -> SlotDecl -> Work -> SelectM m Work +selectSlot lookups receiver owner ref slot work = do + top <- lookupTop lookups owner + work0 <- selectTop lookups owner work + case (top, slot) of + (_, AbstractSlot) -> throwE (AbstractMemberSelected receiver ref owner) + (OpaqueTop{}, AttributeSlot) -> case ref of + AttrRef n -> selectReceiverInitializer lookups receiver n work0 + _ -> throwE (InvalidSlotKind owner ref slot) + (OpaqueTop{}, OpaqueSlot) -> case ref of + AttrRef n -> selectReceiverInitializer lookups receiver n work0 + _ -> return work0 + (OpaqueTop{}, _) -> return work0 + (_, StoredSlot member) -> do + except (validateStoredSlot owner ref member) + selectMember lookups owner member work0 + (_, AttributeSlot) -> + case ref of + AttrRef n -> selectAttributeSlot lookups receiver owner n work0 + _ -> throwE (InvalidSlotKind owner ref slot) + (_, OpaqueSlot) -> return work0 + +validateStoredSlot :: TopKey -> MemberRef -> Rows.MemberKey -> Either SelectionError () +validateStoredSlot owner (MethodRef n) member@(Rows.Method n') + | n == n' = Right () + | otherwise = Left (InvalidStoredSlot owner (MethodRef n) member) +validateStoredSlot owner ref member = Left (InvalidStoredSlot owner ref member) + +selectGenerated :: Monad m => TopKey -> MemberRef -> ReachSummary -> Work -> SelectM m Work +selectGenerated owner ref summary work + | hasRow row work = return work + | otherwise = return (enqueueSummary summary $ keepRow row work) + where row = GeneratedRow owner ref + + +-- Exact provider resolution ----------------------------------------------------------------------------- + +resolveSlot :: Monad m => ReachLookup m -> TopKey -> MemberRef -> SelectM m (TopKey, SlotDecl) +resolveSlot lookups receiver ref = do + mSlot <- loadSlotRow lookups receiver ref + case mSlot of + Nothing -> throwE (MissingSlot receiver ref) + Just (SlotInfo owner slot) -> do + except (validateSlot owner ref slot) + return (owner, slot) + +validateSlot :: TopKey -> MemberRef -> SlotDecl -> Either SelectionError () +validateSlot owner ref (StoredSlot member) = validateStoredSlot owner ref member +validateSlot _ (AttrRef _) AttributeSlot = Right () +validateSlot _ _ AbstractSlot = Right () +validateSlot _ _ OpaqueSlot = Right () +validateSlot owner ref slot = Left (InvalidSlotKind owner ref slot) + +lookupReflectableRefs :: Monad m => ReachLookup m -> TopKey -> SelectM m [MemberRef] +lookupReflectableRefs lookups receiver = do + shape <- lookupShape lookups receiver + names <- foldM load Set.empty (shapeLineage shape) + return (map AttrRef $ Set.toAscList names) + where + load names owner = do + mAttrs <- loadReflectableAttrs lookups owner + attrs <- case mAttrs of + Nothing -> throwE (MissingReflectableAttrs owner) + Just found -> return (reflectableAttrs found) + return (Set.union names $ Set.fromList attrs) + +compatible :: Monad m => ReachLookup m -> TopKey -> TopKey -> SelectM m Bool +compatible lookups receiver concrete = do + shape <- lookupShape lookups concrete + return (receiver `elem` shapeLineage shape) + + +-- Construction and initialization ---------------------------------------------------------------------- + +constructShape :: Monad m => ReachLookup m -> TopKey -> Work -> SelectM m Work +constructShape lookups concrete work = do + work0 <- selectTop lookups concrete work + shape <- lookupShape lookups concrete + case shapeKind shape of + ProtocolShape -> throwE (ProtocolConstructed concrete) + _ -> return () + let abstracts = shapeAbstracts shape + if not (null abstracts) + then throwE (AbstractClassConstructed concrete abstracts) + else if Set.member concrete (workConstructed work0) + then return work0 + else do + let work1 = enqueue (InitializeWork concrete) work0 + { workConstructed = Set.insert concrete (workConstructed work0) } + work2 <- retainOpaqueBarrierAttrs shape work1 + work3 <- retainWitnessSlots shape work2 + work4 <- foldM (replayDispatch lookups concrete) work3 + (Set.toAscList $ workDispatches work3) + foldM (replayReflection lookups concrete) work4 + (Set.toAscList $ workReflections work4) + where + retainOpaqueBarrierAttrs shape selected = do + lineage <- mapM classify (shapeLineage shape) + if not (hasOpaqueBarrier lineage) + then return selected + else do + slots <- loadSurfaceSlots lookups concrete + foldM (retainBarrierAttr lineage) selected slots + + classify key = do + top <- lookupTop lookups key + return (key,top) + + retainBarrierAttr lineage selected (ref@(AttrRef _),SlotInfo provider slot) + | crossesOpaque lineage provider = do + providerTop <- lookupTop lookups provider + case providerTop of + LocalTop{} -> selectSlot lookups concrete provider ref slot selected + OpaqueTop{} -> return selected + retainBarrierAttr _ selected _ = return selected + + crossesOpaque lineage provider = case break ((== provider) . fst) lineage of + (prefix,_:_) -> any (opaque . snd) prefix + _ -> False + + hasOpaqueBarrier [] = False + hasOpaqueBarrier ((_,top):rest) = + opaque top && any (not . opaque . snd) rest || hasOpaqueBarrier rest + + opaque OpaqueTop{} = True + opaque LocalTop{} = False + + retainWitnessSlots shape selected + | shapeKind shape /= WitnessShape = return selected + | otherwise = do + slots <- loadSurfaceSlots lookups concrete + foldM retain selected slots + + retain selected (_,SlotInfo _ AbstractSlot) = return selected + retain selected (ref,_) = directMember lookups concrete ref selected + +resolveConstructor :: Monad m => ReachLookup m -> TopKey -> SelectM m (TopKey, ConstructorDecl) +resolveConstructor lookups receiver = do + shape <- lookupShape lookups receiver + case shapeConstructor shape of + Nothing -> throwE (MissingConstructor receiver) + Just constructor -> return constructor + +initializeReceiver :: Monad m => ReachLookup m -> TopKey -> Work -> SelectM m Work +initializeReceiver lookups receiver work = do + work0 <- selectTop lookups receiver work + (provider, constructor) <- resolveConstructor lookups receiver + activateConstructor lookups receiver provider constructor work0 + +activateConstructor :: Monad m + => ReachLookup m + -> TopKey + -> TopKey + -> ConstructorDecl + -> Work + -> SelectM m Work +activateConstructor lookups receiver provider constructor work + | Set.member receiver (workInitialized work) = return work + | otherwise = do + work0 <- selectTop lookups receiver work + let work1 = work0{ workInitialized = Set.insert receiver (workInitialized work0) } + providerTop <- lookupTop lookups provider + work2 <- case constructor of + StoredConstructor summary -> do + let withSummary = enqueueSummary summary work1 + case providerTop of + LocalTop{} -> selectMember lookups provider Rows.InitRest withSummary + OpaqueTop{} -> return withSummary + GeneratedConstructor summary -> case providerTop of + LocalTop{} -> selectGenerated provider (MethodRef Builtin.initKW) summary work1 + OpaqueTop{} -> return (enqueueSummary summary work1) + InheritedConstructor summary -> + initializeReceiver lookups provider (enqueueSummary summary work1) + OpaqueConstructor -> selectTop lookups provider work1 + foldM (selectInitForField lookups receiver) work2 (selectedWorkAttrs work2) + +selectAttr :: Monad m => ReachLookup m -> TopKey -> A.Name -> Work -> SelectM m Work +selectAttr lookups owner attr work + | hasRow row work = return work + | otherwise = do + work0 <- selectTop lookups owner work + info <- lookupMemberInfo lookups owner (Rows.Attr attr) + work1 <- selectMember lookups owner (Rows.Attr attr) work0 + let work2 = keepRow row work1 + work3 <- activateStaticInitializer lookups owner attr info work2 + foldM selectInit work3 + [ (initOwner, field) | initOwner <- Set.toAscList (workInitialized work2) ] + where field = (owner, attr) + row = AttrRow owner attr + selectInit w (initOwner, demanded) = + selectInitForField lookups initOwner w demanded + +selectAttributeSlot :: Monad m + => ReachLookup m + -> TopKey + -> TopKey + -> A.Name + -> Work + -> SelectM m Work +selectAttributeSlot lookups receiver owner name work = do + selected <- selectAttr lookups owner name work + selectInitForField lookups receiver selected (owner,name) + +selectReceiverInitializer :: Monad m + => ReachLookup m + -> TopKey + -> A.Name + -> Work + -> SelectM m Work +selectReceiverInitializer lookups receiver name work = do + top <- lookupTop lookups receiver + case top of + OpaqueTop{} -> return work + LocalTop{} -> do + mInfo <- lookupMemberInfoMaybe lookups receiver (Rows.Attr name) + case mInfo of + Nothing -> return work + Just info -> do + selected <- selectAttr lookups receiver name work + activateInstanceInitializer lookups receiver name info selected + +selectInitForField :: Monad m => ReachLookup m -> TopKey -> Work -> (TopKey, A.Name) -> SelectM m Work +selectInitForField lookups initOwner work field@(fieldOwner, attr) = do + applies <- compatible lookups fieldOwner initOwner + if not applies + then return work + else do + mInfo <- lookupMemberInfoMaybe lookups initOwner (Rows.Attr attr) + case mInfo of + Nothing -> return work + Just info -> do + (provider, slot) <- resolveSlot lookups initOwner (AttrRef attr) + case slot of + AttributeSlot | (provider, attr) == field -> + activateInstanceInitializer lookups initOwner attr info work + OpaqueSlot | (provider, attr) == field -> return work + _ -> return work + +activateStaticInitializer :: Monad m => ReachLookup m -> TopKey -> A.Name -> MemberInfo -> Work -> SelectM m Work +activateStaticInitializer lookups owner attr info work = + case memberStaticInitSummary info of + Nothing -> return work + Just summary + | hasRow row work -> return work + | otherwise -> do + work0 <- selectMember lookups owner (Rows.Attr attr) work + return (enqueueSummary summary $ keepRow row work0) + where row = StaticInitRow owner attr + +activateInstanceInitializer :: Monad m => ReachLookup m -> TopKey -> A.Name -> MemberInfo -> Work -> SelectM m Work +activateInstanceInitializer lookups owner attr info work = + case memberInstanceInitSummary info of + Nothing -> return work + Just summary + | hasRow row work -> return work + | otherwise -> do + work0 <- selectMember lookups owner (Rows.Attr attr) work + return (enqueueSummary summary $ keepRow row work0) + where row = InstanceInitRow owner attr + + +-- Dynamic dispatch and reflection ----------------------------------------------------------------------- + +dispatchMember :: Monad m => ReachLookup m -> TopKey -> MemberRef -> Work -> SelectM m Work +dispatchMember lookups receiver ref work = do + work0 <- selectTop lookups receiver work + work1 <- retainReceiverDeclaration lookups receiver ref work0 + let work2 = work1{ workDispatches = Set.insert (receiver, ref) (workDispatches work1) } + foldM (dispatchToConstructed lookups receiver ref) work2 (Set.toAscList $ workConstructed work2) + +-- Attribute declarations and their exact receiver initializer are required +-- even when no constructor is visible in the closed-world runtime set: an +-- opaque call can still return an instance of the static receiver. Overrides +-- remain tied to the concrete receivers replayed below. +retainReceiverDeclaration :: Monad m + => ReachLookup m + -> TopKey + -> MemberRef + -> Work + -> SelectM m Work +retainReceiverDeclaration _ _ MethodRef{} work = return work +retainReceiverDeclaration lookups receiver ref@(AttrRef _) work = do + (provider, slot) <- resolveSlot lookups receiver ref + case slot of + AttributeSlot -> selectSlot lookups receiver provider ref slot work + OpaqueSlot -> selectSlot lookups receiver provider ref slot work + _ -> return work + +dispatchToConstructed :: Monad m => ReachLookup m -> TopKey -> MemberRef -> Work -> TopKey -> SelectM m Work +dispatchToConstructed lookups receiver ref work concrete = do + applies <- compatible lookups receiver concrete + if applies then enqueueDispatchPair receiver ref concrete work else return work + +replayDispatch :: Monad m => ReachLookup m -> TopKey -> Work -> (TopKey, MemberRef) -> SelectM m Work +replayDispatch lookups concrete work (receiver, ref) = + dispatchToConstructed lookups receiver ref work concrete + +enqueueDispatchPair :: Monad m => TopKey -> MemberRef -> TopKey -> Work -> SelectM m Work +enqueueDispatchPair receiver ref concrete work + | Set.member key (workDispatchPairs work) = return work + | otherwise = return $ enqueueReach (edgeDirect concrete ref) work + { workDispatchPairs = Set.insert key (workDispatchPairs work) } + where key = (receiver, ref, concrete) + +reflectShape :: Monad m => ReachLookup m -> TopKey -> Work -> SelectM m Work +reflectShape lookups receiver work = do + work0 <- selectTop lookups receiver work + let work1 = work0{ workReflections = Set.insert receiver (workReflections work0) } + foldM (reflectConstructed lookups receiver) work1 (Set.toAscList $ workConstructed work1) + +reflectConstructed :: Monad m => ReachLookup m -> TopKey -> Work -> TopKey -> SelectM m Work +reflectConstructed lookups receiver work concrete = do + applies <- compatible lookups receiver concrete + if applies then enqueueReflectionPair receiver concrete work else return work + +replayReflection :: Monad m => ReachLookup m -> TopKey -> Work -> TopKey -> SelectM m Work +replayReflection lookups concrete work receiver = reflectConstructed lookups receiver work concrete + +enqueueReflectionPair :: Monad m => TopKey -> TopKey -> Work -> SelectM m Work +enqueueReflectionPair receiver concrete work + | Set.member key (workReflectionPairs work) = return work + | otherwise = return $ enqueue (ReflectWork receiver concrete) work + { workReflectionPairs = Set.insert key (workReflectionPairs work) } + where key = (receiver, concrete) + +reflectConcrete :: Monad m => ReachLookup m -> TopKey -> TopKey -> Work -> SelectM m Work +reflectConcrete lookups receiver concrete work = do + applies <- compatible lookups receiver concrete + if not applies + then return work + else do + attrs <- lookupReflectableRefs lookups concrete + return $ foldl (flip $ enqueueReach . edgeDirect concrete) work attrs + + +-- Queue helpers ----------------------------------------------------------------------------------------- + +enqueue :: WorkItem -> Work -> Work +enqueue item work = work{ workQueue = workQueue work Seq.|> item } + +enqueueReach :: ReachEdge -> Work -> Work +enqueueReach = enqueue . ReachWork + +enqueueSummary :: ReachSummary -> Work -> Work +enqueueSummary summary work = foldl (flip enqueueReach) work (reachEdges summary) + +edgeDirect :: TopKey -> MemberRef -> ReachEdge +edgeDirect (TopKey mn n) = Direct mn n diff --git a/compiler/lib/src/Acton/ReachabilityRows.hs b/compiler/lib/src/Acton/ReachabilityRows.hs new file mode 100644 index 000000000..2311ebceb --- /dev/null +++ b/compiler/lib/src/Acton/ReachabilityRows.hs @@ -0,0 +1,185 @@ +-- SPDX-License-Identifier: BSD-3-Clause + +{-# LANGUAGE DeriveGeneric #-} + +-- | Persisted, exactly addressable facts used by reachability closure. +-- +-- These rows are the semantic counterpart of 'InterfaceRows': interface rows +-- hold independently loadable syntax, while reachability rows say which other +-- top-level names, members, constructors and generated slots that syntax +-- needs. 'Reachability.prepareReachabilityRows' prepares the rows during the +-- front pass, 'InterfaceFiles' stores them in TYDB, and +-- 'Reachability.selectProgram' reads only the exact rows reached from the +-- program roots. +-- +-- This module owns the persisted representation, not syntax traversal, +-- whole-program closure, or interface-file IO. +module Acton.ReachabilityRows + ( MemberRef(..) + , ReachEdge(..) + , ReachSummary + , reachEdges + , reachSummaryFromEdges + , singletonReach + , TopKey(..) + , TopInfo(..) + , ShapeKind(..) + , ConstructorDecl(..) + , SlotDecl(..) + , MemberInfo(..) + , ShapeInfo(..) + , SlotInfo(..) + , ReflectableAttrs(..) + , ReachabilityRows(..) + , emptyReachabilityRows + ) where + +import qualified Acton.InterfaceRows as Rows +import qualified Acton.NameInfo as I +import qualified Acton.Syntax as A + +import Control.DeepSeq (NFData) +import qualified Data.Map.Strict as Map +import qualified Data.Persist as Persist +import qualified Data.Set as Set +import GHC.Generics (Generic) + + +-- Dependencies ----------------------------------------------------------------------------------------- + +data MemberRef = MethodRef A.Name | AttrRef A.Name + deriving (Eq, Ord, Show, Read, Generic) + +instance NFData MemberRef +instance Persist.Persist MemberRef + +data ReachEdge = Declare A.ModName A.Name + | Need A.ModName A.Name + | Construct A.ModName A.Name + | Direct A.ModName A.Name MemberRef + | Dispatch A.ModName A.Name MemberRef + | Reflect A.ModName A.Name + | DynamicSerialization + | DeclareAttr A.ModName A.Name A.Name + deriving (Eq, Ord, Show, Read, Generic) + +instance NFData ReachEdge +instance Persist.Persist ReachEdge + +newtype ReachSummary = ReachSummary { reachEdgeSet :: Set.Set ReachEdge } + deriving (Eq, Show, Generic) + +instance NFData ReachSummary +instance Persist.Persist ReachSummary + +instance Semigroup ReachSummary where + ReachSummary es <> ReachSummary es' = ReachSummary (Set.union es es') + +instance Monoid ReachSummary where + mempty = ReachSummary Set.empty + +reachEdges :: ReachSummary -> [ReachEdge] +reachEdges (ReachSummary edges) = Set.toAscList edges + +reachSummaryFromEdges :: [ReachEdge] -> ReachSummary +reachSummaryFromEdges = ReachSummary . Set.fromList + +singletonReach :: ReachEdge -> ReachSummary +singletonReach edge = ReachSummary (Set.singleton edge) + + +-- Persisted row payloads -------------------------------------------------------------------------------- + +data TopKey = TopKey A.ModName A.Name + deriving (Eq, Ord, Show, Generic) + +instance NFData TopKey +instance Persist.Persist TopKey + +data TopInfo = LocalTop (Maybe I.NameInfo) ReachSummary | OpaqueTop ReachSummary + deriving (Eq, Show, Generic) + +instance NFData TopInfo +instance Persist.Persist TopInfo + +data ShapeKind = ClassShape | ActorShape | WitnessShape | ProtocolShape + deriving (Eq, Ord, Show, Generic) + +instance NFData ShapeKind +instance Persist.Persist ShapeKind + +data ConstructorDecl + = StoredConstructor ReachSummary + | GeneratedConstructor ReachSummary + | InheritedConstructor ReachSummary + | OpaqueConstructor + deriving (Eq, Show, Generic) + +instance NFData ConstructorDecl +instance Persist.Persist ConstructorDecl + +data SlotDecl + = StoredSlot Rows.MemberKey + | AttributeSlot + | AbstractSlot + | OpaqueSlot + deriving (Eq, Show, Generic) + +instance NFData SlotDecl +instance Persist.Persist SlotDecl + +data MemberInfo = MemberInfo + { memberSummary :: ReachSummary + , memberStaticInitSummary :: Maybe ReachSummary + , memberInstanceInitSummary :: Maybe ReachSummary + } deriving (Eq, Show, Generic) + +instance NFData MemberInfo +instance Persist.Persist MemberInfo + +-- Effective slots and reflectable attributes deliberately live in their own +-- exact-key rows. Shape rows stay compact and never become an attribute +-- manifest that must be loaded merely to select the shape itself. +data ShapeInfo = ShapeInfo + { shapeName :: TopKey + , shapeKind :: ShapeKind + , shapeLineage :: [TopKey] + , shapeConstructor :: Maybe (TopKey, ConstructorDecl) + , shapeAbstracts :: [MemberRef] + } deriving (Eq, Show, Generic) + +instance NFData ShapeInfo +instance Persist.Persist ShapeInfo + +data SlotInfo = SlotInfo + { slotProvider :: TopKey + , slotDecl :: SlotDecl + } deriving (Eq, Show, Generic) + +instance NFData SlotInfo +instance Persist.Persist SlotInfo + +newtype ReflectableAttrs = ReflectableAttrs { reflectableAttrs :: [A.Name] } + deriving (Eq, Show, Generic) + +instance NFData ReflectableAttrs +instance Persist.Persist ReflectableAttrs + + +-- In-memory preparation result ------------------------------------------------------------------------- + +data ReachabilityRows = ReachabilityRows + { reachModuleSummary :: ReachSummary + , reachWholeSummary :: ReachSummary + , reachTopRows :: Map.Map TopKey TopInfo + , reachMemberRows :: Map.Map (TopKey, Rows.MemberKey) MemberInfo + , reachShapeRows :: Map.Map TopKey ShapeInfo + , reachSlotRows :: Map.Map (TopKey, MemberRef) SlotInfo + , reachReflectableRows :: Map.Map TopKey ReflectableAttrs + } deriving (Eq, Show, Generic) + +instance NFData ReachabilityRows + +emptyReachabilityRows :: ReachabilityRows +emptyReachabilityRows = ReachabilityRows + mempty mempty Map.empty Map.empty Map.empty Map.empty Map.empty diff --git a/compiler/lib/src/Acton/Testing.hs b/compiler/lib/src/Acton/Testing.hs index 617ad7d22..797f1df50 100644 --- a/compiler/lib/src/Acton/Testing.hs +++ b/compiler/lib/src/Acton/Testing.hs @@ -32,7 +32,6 @@ module Acton.Testing import qualified Acton.Compile as Compile import qualified Acton.Env -import qualified Acton.Hashing as Hashing import qualified Acton.Syntax as A import qualified InterfaceFiles import Utils (prstr) @@ -300,7 +299,7 @@ hashRun implHash depsHash ctxHash = toHex (SHA256.hash (B.concat [implHash, deps -- | Hash a dependency list with a stable ordering. hashDeps :: [(A.QName, B.ByteString)] -> B.ByteString hashDeps deps = - let sorted = Data.List.sortOn (Hashing.qnameKey . fst) deps + let sorted = Data.List.sortOn fst deps in SHA256.hash (BL.toStrict (encode sorted)) -- | Shorten a hash to 8 hex characters. diff --git a/compiler/lib/src/InterfaceFiles.hs b/compiler/lib/src/InterfaceFiles.hs index 61fa5fe27..819769633 100644 --- a/compiler/lib/src/InterfaceFiles.hs +++ b/compiler/lib/src/InterfaceFiles.hs @@ -11,7 +11,7 @@ -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DerivingStrategies, ScopedTypeVariables #-} -- Acton Interface (.tydb) Files -- -- Purpose @@ -45,36 +45,50 @@ -- "constructors" :: [A.Name] -- public class/protocol/actor names -- "actors" :: [A.Name] -- public actor names -- "stmt-count" :: Int -- number of typed top-level statements +-- "stmt-mandatory" :: [Int] -- ownerless top-level statement indexes -- "stmt-has-not-impl" :: Bool -- any statement contains NotImplemented +-- "module-hash" :: ModuleHashInfo -- ownerless module-init hash and deps -- "module-header" :: (A.ModName, Imports, Maybe String) -- -- typed module name, imports, docstring -- -- Per-name keys (NameInfo / TEnv, one set per name): --- "name-order/" :: ByteString -- name-key suffix, in TEnv order (NNN = padIndex) --- "name-info/" :: (A.Name, I.NameInfo) -- the name and its type/name environment entry +-- "name-order/" :: ByteString -- exact ordered-row key (NNN = padIndex) +-- "name-info/order/" :: (A.Name, I.NameInfo) -- every TEnv occurrence, preserving order +-- "name-info/" :: (A.Name, I.NameInfo) -- last occurrence for direct lookup -- "name-hash/" :: NameHashInfo -- per-name src/pub/impl hashes + local deps -- -- + owned statement indexes -- -- Per-dependency keys: -- "deps/" :: [DepNameInfo] -- dependency names with pub/impl hashes --- "deps//" :: DepUsers -- local names that use one dependency name +-- "deps/name/" :: DepUsers -- local names that use one dependency name; +-- -- hash covers the complete module/name pair -- -- Per-extension keys: -- "ext-by-class/" :: (A.Name, [A.Name]) -- class name to extension names -- "ext-by-protocol/" :: (A.Name, [A.Name]) -- protocol name to extension names -- -- Per-query index keys: --- "con-attr/" :: [A.Name] -- class/actor names declaring an attribute --- "proto-attr/" :: [A.Name] -- protocol names declaring an attribute --- "descendants/" :: [A.Name] -- class/protocol names below a constructor --- "ext-proto/" :: [A.Name] -- extension names implementing a protocol --- "ext-type/" :: [A.Name] -- extension names for a type/class +-- "con-attr/" :: (A.Name, [A.Name]) -- class/actor names declaring an attribute +-- "proto-attr/" :: (A.Name, [A.Name]) -- protocol names declaring an attribute +-- "descendants/" :: (A.QName, [A.Name]) -- class/protocol names below a constructor +-- "ext-proto/" :: (A.QName, [A.Name]) -- extension names implementing a protocol +-- "ext-type/" :: (A.QName, [A.Name]) -- extension names for a type/class -- --- Per-statement keys (typed Module body): --- "stmt/" :: A.Stmt -- one typed top-level statement (NNN = padIndex) +-- Typed module content keys: +-- "stmt/" :: StoredStmt -- ordered top-level row (NNN = padIndex) +-- "shape/" :: ContainerShape -- compact container header/ABI slots +-- "body/member//" +-- :: MemberContentRow -- independently addressable method/attribute content +-- "reach/top/" :: ReachTopRow +-- "reach/module/" :: ReachModuleRow +-- "reach/member//" :: ReachMemberRow +-- "reach/shape/" :: ReachShapeRow +-- "reach/slot//" :: ReachSlotRow +-- "reach/reflection/" :: ReachReflectionRow -- --- encodes the semantic name: "p/" for plain safe names (used as --- the key verbatim) or "h/" for long or unsafe names. See nameKeySuffix. +-- Name and QName suffixes hash a location-free structural encoding. Module +-- suffixes use their readable path when it is short and LMDB-safe, and a hash +-- otherwise. -- -- Rationale for the keyed layout -- - Keep the small validity/header fields (version, meta, dependency hashes, roots, tests, @@ -92,11 +106,19 @@ module InterfaceFiles , DepModuleInfo(..) , DepNameInfo(..) , DepUsers(..) + , ModuleHashInfo(..) + , emptyModuleHashInfo + , ImplRefreshInput(..) + , ImplRefreshOutput(..) + , ImplRefreshStale(..) , SourceFileMeta(..) + , InterfaceContents(..) + , InterfaceSummary(..) , TyFile , TyHeader , TyHeaderSummary , InterfaceDB + , InterfaceReadSession , interfaceExt , interfacePath , interfaceExists @@ -107,13 +129,26 @@ module InterfaceFiles , registerSystemTypeRoots , keyNameInfo , keyNameHash + , keyContainerShape + , keyMemberBody + , keyReachModule + , keyReachTop + , keyReachMember + , keyReachShape + , keyReachSlot + , keyReachReflection , readDepNames , readDepUsers , readNameHashMaybe + , readMemberContent + , readReachabilityRows , readModuleHashesMaybe + , readInterfaceSummaryMaybe + , readImplRefreshInput , readFile , readModuleIface , readNameHashes + , readModuleHashInfo , readStmtHasNotImpl , readHeader , readHeaderSummary @@ -125,6 +160,18 @@ module InterfaceFiles , readHeaderSummaryMaybe , openInterfaceDB , openInterfaceDBMaybe + , withInterfaceReadSession + , readInterfaceSessionNameHashMaybe + , readInterfaceSessionReachSummaries + , readInterfaceSessionReachTop + , readInterfaceSessionReachTopMaybe + , readInterfaceSessionReachMemberMaybe + , readInterfaceSessionReachShapeMaybe + , readInterfaceSessionReachSlotMaybe + , readInterfaceSessionReachSlots + , readInterfaceSessionReachReflectionMaybe + , readInterfaceSessionSelection + , readInterfaceDBIface , readInterfaceDBModuleInfo , readInterfaceDBNameInfoMaybe , readInterfaceDBPublicNames @@ -135,13 +182,14 @@ module InterfaceFiles , readInterfaceDBDescendants , readInterfaceDBExtByProto , readInterfaceDBExtByType - , readSelectedModule , TyDbWriteProgress(..) , writeFile - , writeFileWithProgress - , writeFileWithVersion + , writeVersionedFile , updateSourceMeta + , updateSourceHashAndNameHashes , updateImplRefresh + , isImplRefreshStale + , updateVersion ) where import Prelude hiding (readFile, writeFile) @@ -150,25 +198,32 @@ import qualified Control.Exception as E import Control.Concurrent (getNumCapabilities, runInBoundThread, threadDelay) import Control.Concurrent.Async (mapConcurrently) import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar, withMVar) -import Control.Monad (forM, forM_, unless, when) +import Control.Monad (foldM, forM, forM_, replicateM, unless, when) import Data.IORef (atomicModifyIORef', newIORef) import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B import qualified Data.List -import qualified Data.Set import Data.List (foldl') import qualified Data.IntSet as IntSet import qualified Data.Map.Strict as Map import qualified Data.Persist as Persist import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE import Data.Time.Clock (UTCTime) import qualified Database.LMDB.Raw as LMDB import qualified Acton.Syntax as A +import Acton.InterfaceRows + ( MemberKey(..) + , MemberContent(..) + , ContainerShape(..) + , StoredStmt(..) + , StoredDecl(..) + , InterfaceRows(..) + ) +import qualified Acton.InterfaceRows as Rows import qualified Acton.NameInfo as I +import qualified Acton.ReachabilityRows as ReachRows import Acton.Names (isPublicName) import qualified Acton.Names as Names import Utils (SrcLoc(NoLoc), chunksOf) @@ -182,6 +237,7 @@ import System.IO (hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) import System.IO.Unsafe (unsafePerformIO) import System.Posix.Files (deviceID, fileAccess, fileID, getFileStatus, modificationTimeHiRes, setFileMode) +import System.Random (randomIO) data NameHashInfo = NameHashInfo { nhName :: A.Name @@ -199,39 +255,72 @@ data NameHashInfo = NameHashInfo , nhImplDeps :: [(A.QName, BS.ByteString)] , nhStmtIndices :: [Int] } deriving (Show, Eq, Generic) - -instance Persist.Persist NameHashInfo -instance NFData NameHashInfo + deriving anyclass (Persist.Persist, NFData) data DepModuleInfo = DepModuleInfo { dmiModule :: A.ModName , dmiPubHash :: BS.ByteString , dmiImplHash :: BS.ByteString } deriving (Show, Eq, Generic) - -instance Persist.Persist DepModuleInfo -instance NFData DepModuleInfo + deriving anyclass (Persist.Persist, NFData) data DepNameInfo = DepNameInfo { dniName :: A.Name , dniPubHash :: BS.ByteString , dniImplHash :: BS.ByteString } deriving (Show, Eq, Generic) - -instance Persist.Persist DepNameInfo -instance NFData DepNameInfo + deriving anyclass (Persist.Persist, NFData) data DepUsers = DepUsers { duPubUsers :: [A.Name] , duImplUsers :: [A.Name] } deriving (Show, Eq, Generic) - -instance Persist.Persist DepUsers -instance NFData DepUsers + deriving anyclass (Persist.Persist, NFData) emptyDepUsers :: DepUsers emptyDepUsers = DepUsers [] [] +-- | The implementation component owned by the module rather than a top-level +-- name. The compact statement-owner schedule preserves initialization order +-- across independently hashed names; mandatory ownerless statements keep +-- their own structural hash and exact dependency rows. Together these rows +-- are sufficient for an implementation refresh without loading typed syntax. +data ModuleHashInfo = ModuleHashInfo + { mhOwnImplHash :: BS.ByteString + , mhStatementOwners :: [[A.Name]] + , mhImplHash :: BS.ByteString + , mhImplLocalDeps :: [A.Name] + , mhPubDeps :: [(A.QName, BS.ByteString)] + , mhImplDeps :: [(A.QName, BS.ByteString)] + } deriving (Show, Eq, Generic) + deriving anyclass (Persist.Persist, NFData) + +emptyModuleHashInfo :: ModuleHashInfo +emptyModuleHashInfo = ModuleHashInfo BS.empty [] BS.empty [] [] [] + +-- | The complete stored input to an implementation-only hash refresh. All +-- fields are captured in one read transaction and the identity fields are +-- checked again by 'updateImplRefresh' before it mutates the interface. +data ImplRefreshInput = ImplRefreshInput + { iriGeneration :: BS.ByteString + , iriSourceHash :: BS.ByteString + , iriPublicHash :: BS.ByteString + , iriImplementationHash :: BS.ByteString + , iriModuleHashInfo :: ModuleHashInfo + , iriDependencies :: [DepModuleInfo] + , iriNameHashes :: [NameHashInfo] + , iriRoots :: [A.Name] + , iriHasNotImpl :: Bool + } deriving (Show, Eq) + +-- | Newly computed hash rows for an implementation-only refresh. +data ImplRefreshOutput = ImplRefreshOutput + { iroImplementationHash :: BS.ByteString + , iroModuleHashInfo :: ModuleHashInfo + , iroDependencies :: [DepModuleInfo] + , iroNameHashes :: [NameHashInfo] + } deriving (Show, Eq) + data ExtensionIndex = ExtensionIndex { extByClass :: Map.Map A.Name [A.Name] , extByProtocol :: Map.Map A.Name [A.Name] @@ -244,9 +333,24 @@ data SourceFileMeta = SourceFileMeta , sfmDevice :: Maybe Integer , sfmInode :: Maybe Integer } deriving (Show, Eq, Generic) - -instance Persist.Persist SourceFileMeta -instance NFData SourceFileMeta + deriving anyclass (Persist.Persist, NFData) + +data InterfaceContents = InterfaceContents + { ifcSourceHash :: BS.ByteString + , ifcPublicHash :: BS.ByteString + , ifcImplementationHash :: BS.ByteString + , ifcModuleHashInfo :: ModuleHashInfo + , ifcSourceMeta :: Maybe SourceFileMeta + , ifcImports :: [(A.ModName, BS.ByteString)] + , ifcDependencies :: [DepModuleInfo] + , ifcNameHashes :: [NameHashInfo] + , ifcRoots :: [A.Name] + , ifcTests :: [String] + , ifcDoc :: Maybe String + , ifcModule :: I.NModule + , ifcRows :: InterfaceRows + , ifcReachabilityRows :: ReachRows.ReachabilityRows + } data TyDbWriteProgress = TyDbWriteProgress { tyDbWriteProgressLabel :: String @@ -302,6 +406,21 @@ type TyMeta = , BS.ByteString ) +-- | The small interface facts needed to prepare a +-- deferred back pass. Source imports reconstruct ModuleInfo, while closure +-- imports include implicit dependencies such as __builtin__. +data InterfaceSummary = InterfaceSummary + { summarySourceHash :: BS.ByteString + , summaryPublicHash :: BS.ByteString + , summaryImplementationHash :: BS.ByteString + , summaryModuleName :: A.ModName + , summarySourceImports :: [A.ModName] + , summaryClosureImports :: [A.ModName] + , summaryRoots :: [A.Name] + , summaryHasNotImpl :: Bool + , summaryDoc :: Maybe String + } deriving (Show, Eq) + -- | A handle for selective per-name and per-index lookups in one module's -- .tydb: the version is validated once at open, and each lookup runs a short -- read transaction on the shared per-path environment. @@ -310,6 +429,19 @@ newtype InterfaceDB = InterfaceDB FilePath instance Show InterfaceDB where show (InterfaceDB path) = "InterfaceDB " ++ path +interfaceDBPath :: InterfaceDB -> FilePath +interfaceDBPath (InterfaceDB path) = path + +-- | A read transaction shared by a group of exact-key +-- lookups. Selective compilation keeps one session per participating module, +-- so a huge interface is mapped and entered once without loading unrelated +-- rows. +data InterfaceReadSession = InterfaceReadSession + FilePath LMDB.MDB_txn LMDB.MDB_dbi + +interfaceReadSessionPath :: InterfaceReadSession -> FilePath +interfaceReadSessionPath (InterfaceReadSession path _ _) = path + -- Note: tests are stored in the header to support listing without compiling -- or executing test binaries. @@ -404,11 +536,21 @@ copyInterface src dst = do runInLmdbThread $ withEnv src True mapSize $ \env -> LMDB.mdb_env_copy env dst + renewInterfaceGeneration dst + removeFile (lockFilePath dst) `E.catch` ignoreMissing setReadableInterfacePermissions dst where ignoreMissing :: E.IOException -> IO () ignoreMissing _ = return () +renewInterfaceGeneration :: FilePath -> IO () +renewInterfaceGeneration f = do + generation <- newInterfaceGeneration + size <- readMapSize f + withWriteTxn f size $ \txn dbi -> do + validateVersion txn dbi + putValue txn dbi keyGeneration (encodeStrict generation) + listInterfaceDirsRecursive :: FilePath -> IO [FilePath] listInterfaceDirsRecursive root = do entries <- listDirectory root @@ -431,6 +573,16 @@ newtype TyCacheInvalid = TyCacheInvalid String deriving Show instance E.Exception TyCacheInvalid +newtype ImplRefreshStale = ImplRefreshStale String deriving Show + +instance E.Exception ImplRefreshStale + +isImplRefreshStale :: E.SomeException -> Bool +isImplRefreshStale err = + case E.fromException err :: Maybe ImplRefreshStale of + Just _ -> True + Nothing -> False + versionMismatch :: [Int] -> IO a versionMismatch vs = E.throwIO (TyCacheInvalid (".tydb version mismatch: file has " ++ show vs ++ ", expected " ++ show A.version)) @@ -447,8 +599,9 @@ encodeStrict = Persist.encode key :: String -> BS.ByteString key = B.pack -keyVersion, keyMeta, keyImports, keyDeps, keyRoots, keyTests, keyDoc, keyNameCount, keyPublicNames, keyConstructors, keyActors, keyStmtCount, keyStmtHasNotImpl, keyModuleHeader :: BS.ByteString +keyVersion, keyGeneration, keyMeta, keyImports, keyDeps, keyRoots, keyTests, keyDoc, keyNameCount, keyPublicNames, keyConstructors, keyActors, keyStmtCount, keyStmtMandatory, keyStmtHasNotImpl, keyModuleHash, keyModuleHeader :: BS.ByteString keyVersion = key "version" +keyGeneration = key "generation" keyMeta = key "meta" keyImports = key "imports" keyDeps = key "deps" @@ -460,46 +613,37 @@ keyPublicNames = key "public-names" keyConstructors = key "constructors" keyActors = key "actors" keyStmtCount = key "stmt-count" +keyStmtMandatory = key "stmt-mandatory" keyStmtHasNotImpl = key "stmt-has-not-impl" +keyModuleHash = key "module-hash" keyModuleHeader = key "module-header" +-- Every semantic commit receives a fresh nonce. Unlike content hashes this +-- changes across an A -> B -> A rewrite, so selective readers can detect that +-- separate LMDB read transactions did not observe one committed generation. +newInterfaceGeneration :: IO BS.ByteString +newInterfaceGeneration = BS.pack <$> replicateM 32 randomIO + padIndex :: Int -> String padIndex i = let s = show i in replicate (12 - length s) '0' ++ s -plainNameKeyLimit :: Int -plainNameKeyLimit = 400 - -plainKeyRaw :: BS.ByteString -> Bool -plainKeyRaw raw = - BS.length raw <= plainNameKeyLimit && BS.all safe raw - where - safe w = - w > 32 && w < 127 && w /= 47 - -safeKeySuffix :: BS.ByteString -> BS.ByteString -safeKeySuffix raw = - if plainKeyRaw raw - then B.concat [key "p/", raw] - else B.concat [key "h/", Base16.encode (SHA256.hash raw)] - +-- rawstr is a C-symbol rendering, not a one-to-one semantic encoding: a plain +-- source name can spell the same text as a Derived name. Direct indexes must +-- therefore key the location-free Name structure itself. nameKeySuffix :: A.Name -> BS.ByteString nameKeySuffix n = - safeKeySuffix (TE.encodeUtf8 (T.pack (A.rawstr n))) + B.concat [key "h/", semanticDigest (stripNameKeyLocs n)] moduleKeySuffix :: A.ModName -> BS.ByteString -moduleKeySuffix mn = - let raw = TE.encodeUtf8 (T.pack (Data.List.intercalate "." (A.modPath mn))) - in if plainKeyRaw raw - then raw - else B.concat [key "h/", Base16.encode (SHA256.hash raw)] +moduleKeySuffix = semanticDigest . stripModNameKeyLocs keyNameInfo :: A.Name -> BS.ByteString keyNameInfo n = B.concat [key "name-info/", nameKeySuffix n] -keyNameInfoSuffix :: BS.ByteString -> BS.ByteString -keyNameInfoSuffix suffix = B.concat [key "name-info/", suffix] +keyNameInfoOrder :: Int -> BS.ByteString +keyNameInfoOrder i = B.pack ("name-info/order/" ++ padIndex i) keyNameOrder :: Int -> BS.ByteString keyNameOrder i = B.pack ("name-order/" ++ padIndex i) @@ -510,11 +654,77 @@ keyNameHashPrefix = key "name-hash/" keyNameHash :: A.Name -> BS.ByteString keyNameHash n = B.concat [keyNameHashPrefix, nameKeySuffix n] +keyContainerShape :: A.Name -> BS.ByteString +keyContainerShape n = B.concat [key "shape/", nameKeySuffix n] + +keyMemberBodyPrefix :: A.Name -> BS.ByteString +keyMemberBodyPrefix owner = + B.concat [key "body/member/", semanticDigest (stripNameKeyLocs owner), key "/"] + +semanticDigest :: Persist.Persist a => a -> BS.ByteString +semanticDigest = Base16.encode . SHA256.hash . encodeStrict + +keyMemberBody :: A.Name -> MemberKey -> BS.ByteString +keyMemberBody owner member = + B.concat [keyMemberBodyPrefix owner, semanticDigest (stripMemberKeyLocs member)] + +stripMemberKeyLocs :: MemberKey -> MemberKey +stripMemberKeyLocs (Method n) = Method (stripNameKeyLocs n) +stripMemberKeyLocs (Attr n) = Attr (stripNameKeyLocs n) +stripMemberKeyLocs (StaticInit n) = StaticInit (stripNameKeyLocs n) +stripMemberKeyLocs (InstanceInit n) = InstanceInit (stripNameKeyLocs n) +stripMemberKeyLocs InitRest = InitRest + +stripTopKeyLocs :: ReachRows.TopKey -> ReachRows.TopKey +stripTopKeyLocs (ReachRows.TopKey mn n) = + ReachRows.TopKey (stripModNameKeyLocs mn) (stripNameKeyLocs n) + +stripMemberRefLocs :: ReachRows.MemberRef -> ReachRows.MemberRef +stripMemberRefLocs (ReachRows.MethodRef n) = ReachRows.MethodRef (stripNameKeyLocs n) +stripMemberRefLocs (ReachRows.AttrRef n) = ReachRows.AttrRef (stripNameKeyLocs n) + +reachOwnerPrefix :: BS.ByteString -> ReachRows.TopKey -> BS.ByteString +reachOwnerPrefix prefix owner = + B.concat [prefix, semanticDigest (stripTopKeyLocs owner), key "/"] + +keyReachTop :: ReachRows.TopKey -> BS.ByteString +keyReachTop owner = + B.concat [key "reach/top/", semanticDigest (stripTopKeyLocs owner)] + +keyReachMember :: ReachRows.TopKey -> MemberKey -> BS.ByteString +keyReachMember owner member = + B.concat + [ reachOwnerPrefix (key "reach/member/") owner + , semanticDigest (stripMemberKeyLocs member) + ] + +keyReachModule :: A.ModName -> BS.ByteString +keyReachModule mn = + B.concat [key "reach/module/", semanticDigest (stripModNameKeyLocs mn)] + +keyReachShape :: ReachRows.TopKey -> BS.ByteString +keyReachShape owner = + B.concat [key "reach/shape/", semanticDigest (stripTopKeyLocs owner)] + +keyReachSlot :: ReachRows.TopKey -> ReachRows.MemberRef -> BS.ByteString +keyReachSlot owner member = + B.concat + [ reachOwnerPrefix (key "reach/slot/") owner + , semanticDigest (stripMemberRefLocs member) + ] + +keyReachReflection :: ReachRows.TopKey -> BS.ByteString +keyReachReflection owner = + B.concat [key "reach/reflection/", semanticDigest (stripTopKeyLocs owner)] + keyDepModule :: A.ModName -> BS.ByteString keyDepModule mn = B.concat [key "deps/", moduleKeySuffix mn] keyDepName :: A.ModName -> A.Name -> BS.ByteString -keyDepName mn n = B.concat [keyDepModule mn, key "/", nameKeySuffix n] +keyDepName mn n = B.concat + [ key "deps/name/" + , semanticDigest (stripModNameKeyLocs mn, stripNameKeyLocs n) + ] keyExtByClassPrefix, keyExtByProtocolPrefix :: BS.ByteString keyExtByClassPrefix = key "ext-by-class/" @@ -799,6 +1009,12 @@ openInterfaceDBMaybe = readTyMaybe openInterfaceDB withInterfaceDBReadTxn :: InterfaceDB -> (LMDB.MDB_txn -> LMDB.MDB_dbi -> IO a) -> IO a withInterfaceDBReadTxn (InterfaceDB path) action = withReadTxn path action +withInterfaceReadSession :: FilePath -> (InterfaceReadSession -> IO a) -> IO a +withInterfaceReadSession path action = + withReadTxn path $ \txn dbi -> do + validateVersion txn dbi + action (InterfaceReadSession path txn dbi) + -- The raw LMDB binding requires transaction setup from a bound thread; this -- applies to reads too because of its Haskell-side lock guard. runInLmdbThread :: IO a -> IO a @@ -840,8 +1056,11 @@ getMaybeValue label txn dbi k = do Nothing -> return Nothing Just v -> Just <$> (copyVal v >>= decodeStrict label) -getValuesWithPrefix :: LMDB.MDB_txn -> LMDB.MDB_dbi -> BS.ByteString -> IO [BS.ByteString] -getValuesWithPrefix txn dbi prefix = +getEntriesWithPrefix :: LMDB.MDB_txn + -> LMDB.MDB_dbi + -> BS.ByteString + -> IO [(BS.ByteString, BS.ByteString)] +getEntriesWithPrefix txn dbi prefix = E.bracket (LMDB.mdb_cursor_open txn dbi) LMDB.mdb_cursor_close $ \cursor -> withVal prefix $ \start -> withVal BS.empty $ \empty -> @@ -857,7 +1076,11 @@ getValuesWithPrefix txn dbi prefix = else do v <- peek vp >>= copyVal found <- LMDB.mdb_cursor_get LMDB.MDB_NEXT cursor kp vp - (v :) <$> go cursor kp vp found + ((k, v) :) <$> go cursor kp vp found + +getKeysWithPrefix :: LMDB.MDB_txn -> LMDB.MDB_dbi -> BS.ByteString -> IO [BS.ByteString] +getKeysWithPrefix txn dbi prefix = + map fst <$> getEntriesWithPrefix txn dbi prefix putValue :: LMDB.MDB_txn -> LMDB.MDB_dbi -> BS.ByteString -> BS.ByteString -> IO () putValue txn dbi k v = @@ -866,6 +1089,12 @@ putValue txn dbi k v = _ <- LMDB.mdb_put (LMDB.compileWriteFlags []) txn dbi kv vv return () +deleteValue :: LMDB.MDB_txn -> LMDB.MDB_dbi -> BS.ByteString -> IO () +deleteValue txn dbi k = + withVal k $ \kv -> do + _ <- LMDB.mdb_del txn dbi kv Nothing + return () + isMapFull :: E.SomeException -> Bool isMapFull err = case E.fromException err of @@ -889,6 +1118,7 @@ writeEntries = writeEntriesWithProgress (\_ -> return ()) writeEntriesWithProgress :: (Double -> IO ()) -> FilePath -> [(BS.ByteString, BS.ByteString)] -> IO () writeEntriesWithProgress onProgress path entries = do + validateEntryKeys entries fileExists <- doesFileExist path when fileExists (removeFile path) createDirectoryIfMissing True path @@ -918,6 +1148,27 @@ writeEntriesWithProgress onProgress path entries = do when (i == total || i `mod` step == 0) $ onProgress (fromIntegral i / fromIntegral total) +lmdbKeyLimit :: Int +lmdbKeyLimit = 511 + +validateEntryKeys :: [(BS.ByteString, BS.ByteString)] -> IO () +validateEntryKeys entries = do + let keys = map fst entries + tooLong = filter ((> lmdbKeyLimit) . BS.length) keys + counts = Map.fromListWith (+) [ (k,1 :: Int) | k <- keys ] + duplicates = [ (k,n) | (k,n) <- Map.toAscList counts, n > 1 ] + unless (null tooLong) $ + invalidModuleRows + ("LMDB key exceeds " ++ show lmdbKeyLimit ++ " bytes: " ++ + show (maximum $ map BS.length tooLong)) + unless (null duplicates) $ + invalidModuleRows + ("storage keys are not globally unique: " ++ + Data.List.intercalate ", " + [ show (B.unpack k) ++ " (" ++ show n ++ " entries)" + | (k,n) <- duplicates + ]) + setReadableInterfacePermissions :: FilePath -> IO () setReadableInterfacePermissions path = do setFileMode path 0o755 @@ -935,6 +1186,8 @@ validateVersion :: LMDB.MDB_txn -> LMDB.MDB_dbi -> IO () validateVersion txn dbi = do vs <- getValue "version" txn dbi keyVersion unless (vs == A.version) (versionMismatch vs) + _ <- getValue "module-hash" txn dbi keyModuleHash :: IO ModuleHashInfo + return () readMeta :: LMDB.MDB_txn -> LMDB.MDB_dbi -> IO TyMeta readMeta txn dbi = do @@ -948,6 +1201,90 @@ readModuleHashes f = traceTydbRead "module-hashes" f "meta" return (moduleSrcBytesHash, modulePubHash, moduleImplHash) +readInterfaceSummary :: FilePath -> IO InterfaceSummary +readInterfaceSummary f = + withReadTxn f $ \txn dbi -> do + (_sourceMeta, srcHash, pubHash, implHash) <- readMeta txn dbi + hashedImports <- getValue "imports" txn dbi keyImports :: + IO [(A.ModName, BS.ByteString)] + roots <- getValue "roots" txn dbi keyRoots + hasNotImpl <- getValue "stmt-has-not-impl" txn dbi keyStmtHasNotImpl + (moduleName, imports, sourceDoc) <- + getValue "module-header" txn dbi keyModuleHeader + doc <- getValue "doc" txn dbi keyDoc + traceTydbRead "interface-summary" f "meta imports" + return InterfaceSummary + { summarySourceHash = srcHash + , summaryPublicHash = pubHash + , summaryImplementationHash = implHash + , summaryModuleName = moduleName + , summarySourceImports = A.importsOf (A.Module moduleName imports sourceDoc []) + , summaryClosureImports = map fst hashedImports + , summaryRoots = roots + , summaryHasNotImpl = hasNotImpl + , summaryDoc = doc + } + +-- | Read every row used to recompute implementation hashes in one committed +-- interface generation. Typed declarations and statement bodies stay lazy. +readImplRefreshInput :: FilePath -> IO ImplRefreshInput +readImplRefreshInput f = + withReadTxn f $ \txn dbi -> do + (_sourceMeta, srcHash, pubHash, implHash) <- readMeta txn dbi + generation <- getValue "generation" txn dbi keyGeneration + moduleHashInfo <- getValue "module-hash" txn dbi keyModuleHash + dependencies <- getValue "deps" txn dbi keyDeps + storedNameHashes <- readNameHashEntries txn dbi + nameHashes <- restoreNameHashDeps txn dbi dependencies storedNameHashes + roots <- getValue "roots" txn dbi keyRoots + hasNotImpl <- getValue "stmt-has-not-impl" txn dbi keyStmtHasNotImpl + traceTydbRead "impl-refresh" f + ("generation names " ++ show (length nameHashes)) + return ImplRefreshInput + { iriGeneration = generation + , iriSourceHash = srcHash + , iriPublicHash = pubHash + , iriImplementationHash = implHash + , iriModuleHashInfo = moduleHashInfo + , iriDependencies = dependencies + , iriNameHashes = nameHashes + , iriRoots = roots + , iriHasNotImpl = hasNotImpl + } + +-- Per-name rows omit external deps; restore them from the dependency indexes +-- while the caller's read transaction still pins the interface generation. +restoreNameHashDeps :: LMDB.MDB_txn + -> LMDB.MDB_dbi + -> [DepModuleInfo] + -> [NameHashInfo] + -> IO [NameHashInfo] +restoreNameHashDeps txn dbi depModules nameHashes = do + (pubByOwner, implByOwner) <- foldM addModule (Map.empty, Map.empty) depModules + return + [ nh { nhPubDeps = Data.List.sortOn fst (Map.findWithDefault [] (nhName nh) pubByOwner) + , nhImplDeps = Data.List.sortOn fst (Map.findWithDefault [] (nhName nh) implByOwner) + } + | nh <- nameHashes + ] + where + addModule acc depInfo = do + let depMn = dmiModule depInfo + depNames <- readDepNameEntries txn dbi depMn + foldM (addName depMn) acc depNames + + addName depMn (pubAcc, implAcc) depInfo = do + users <- readDepUsersEntry txn dbi depMn (dniName depInfo) + let mkDep h = (A.GName depMn (dniName depInfo), h) + addUser dep m user = Map.insertWith (++) user [dep] m + pubAcc' + | BS.null (dniPubHash depInfo) = pubAcc + | otherwise = foldl' (addUser (mkDep $ dniPubHash depInfo)) pubAcc (duPubUsers users) + implAcc' + | BS.null (dniImplHash depInfo) = implAcc + | otherwise = foldl' (addUser (mkDep $ dniImplHash depInfo)) implAcc (duImplUsers users) + return (pubAcc', implAcc') + readNameEntries :: LMDB.MDB_txn -> LMDB.MDB_dbi -> IO ([(A.Name, I.NameInfo)], [NameHashInfo]) readNameEntries txn dbi = do te <- readNameInfoEntries txn dbi @@ -958,17 +1295,27 @@ readNameInfoEntries :: LMDB.MDB_txn -> LMDB.MDB_dbi -> IO [(A.Name, I.NameInfo)] readNameInfoEntries txn dbi = do nameCount <- getValue "name-count" txn dbi keyNameCount forM [0 .. nameCount - 1] $ \i -> do - suffix <- getValue ("name-order " ++ show i) txn dbi (keyNameOrder i) - getValue ("name-info " ++ show i) txn dbi (keyNameInfoSuffix suffix) + rowKey <- getValue ("name-order " ++ show i) txn dbi (keyNameOrder i) + unless (rowKey == keyNameInfoOrder i) $ + invalidContentRow ("name-info order/key mismatch at " ++ show i) + getValue ("name-info " ++ show i) txn dbi rowKey readNameInfoEntryMaybe :: LMDB.MDB_txn -> LMDB.MDB_dbi -> A.Name -> IO (Maybe (A.Name, I.NameInfo)) -readNameInfoEntryMaybe txn dbi n = - getMaybeValue ("name-info " ++ A.nstr n) txn dbi (keyNameInfo n) +readNameInfoEntryMaybe txn dbi n = do + entry <- getMaybeValue ("name-info " ++ A.nstr n) txn dbi (keyNameInfo n) + forM_ entry $ \(stored,_) -> + unless (stored == n) $ + invalidContentRow ("name-info key/value mismatch for " ++ A.rawstr n) + return entry readNameInfoEntriesByNames :: LMDB.MDB_txn -> LMDB.MDB_dbi -> [A.Name] -> IO I.TEnv readNameInfoEntriesByNames txn dbi ns = - forM ns $ \n -> - getValue ("name-info " ++ A.nstr n) txn dbi (keyNameInfo n) + forM ns $ \n -> do + entry@(stored,_) <- + getValue ("name-info " ++ A.nstr n) txn dbi (keyNameInfo n) + unless (stored == n) $ + invalidContentRow ("name-info key/value mismatch for " ++ A.rawstr n) + return entry readInterfaceDBModuleInfo :: InterfaceDB -> IO ([A.ModName], Maybe String) readInterfaceDBModuleInfo db = @@ -977,139 +1324,410 @@ readInterfaceDBModuleInfo db = doc <- getValue "doc" txn dbi keyDoc return (A.importsOf (A.Module tmn timps tdoc []), doc) +readInterfaceDBIface :: InterfaceDB -> IO ([A.ModName], I.NModule) +readInterfaceDBIface db = do + result@(_, I.NModule _ te _) <- + withInterfaceDBReadTxn db readModuleIfaceEntries + traceTydbRead "iface" (interfaceDBPath db) ("names " ++ show (length te)) + return result + readInterfaceDBNameInfoMaybe :: InterfaceDB -> A.Name -> IO (Maybe (A.Name, I.NameInfo)) -readInterfaceDBNameInfoMaybe db@(InterfaceDB path) n = do +readInterfaceDBNameInfoMaybe db n = do mi <- withInterfaceDBReadTxn db $ \txn dbi -> readNameInfoEntryMaybe txn dbi n - traceTydbRead (case mi of Just _ -> "name-hit"; Nothing -> "name-miss") path (A.nstr n) + traceTydbRead (case mi of Just _ -> "name-hit"; Nothing -> "name-miss") + (interfaceDBPath db) (A.nstr n) return mi readInterfaceDBPublicNames :: InterfaceDB -> IO [A.Name] -readInterfaceDBPublicNames db@(InterfaceDB path) = do +readInterfaceDBPublicNames db = do ns <- withInterfaceDBReadTxn db $ \txn dbi -> getValue "public-names" txn dbi keyPublicNames - traceTydbRead "public-names" path (show (length ns)) + traceTydbRead "public-names" (interfaceDBPath db) (show (length ns)) return ns readInterfaceDBConstructors :: InterfaceDB -> IO I.TEnv -readInterfaceDBConstructors db@(InterfaceDB path) = do +readInterfaceDBConstructors db = do te <- withInterfaceDBReadTxn db $ \txn dbi -> do ns <- getValue "constructors" txn dbi keyConstructors readNameInfoEntriesByNames txn dbi ns - traceTydbRead "constructors" path (show (length te)) + traceTydbRead "constructors" (interfaceDBPath db) (show (length te)) return te readInterfaceDBActors :: InterfaceDB -> IO I.TEnv -readInterfaceDBActors db@(InterfaceDB path) = do +readInterfaceDBActors db = do te <- withInterfaceDBReadTxn db $ \txn dbi -> do ns <- getValue "actors" txn dbi keyActors readNameInfoEntriesByNames txn dbi ns - traceTydbRead "actors" path (show (length te)) + traceTydbRead "actors" (interfaceDBPath db) (show (length te)) return te readInterfaceDBConAttr :: InterfaceDB -> A.Name -> IO I.TEnv readInterfaceDBConAttr db n = - readTEnvIndex db ("con-attr " ++ A.nstr n) (keyConAttr n) + readNameTEnvIndex db ("con-attr " ++ A.nstr n) (keyConAttr n) n readInterfaceDBProtoAttr :: InterfaceDB -> A.Name -> IO I.TEnv readInterfaceDBProtoAttr db n = - readTEnvIndex db ("proto-attr " ++ A.nstr n) (keyProtoAttr n) + readNameTEnvIndex db ("proto-attr " ++ A.nstr n) (keyProtoAttr n) n readInterfaceDBDescendants :: InterfaceDB -> A.QName -> IO I.TEnv readInterfaceDBDescendants db qn = - readTEnvIndex db ("descendants " ++ show qn) (keyDescendants qn) + readQNameTEnvIndex db ("descendants " ++ show qn) (keyDescendants qn) qn readInterfaceDBExtByProto :: InterfaceDB -> A.QName -> IO I.TEnv readInterfaceDBExtByProto db qn = - readTEnvIndex db ("ext-proto " ++ show qn) (keyExtProto qn) + readQNameTEnvIndex db ("ext-proto " ++ show qn) (keyExtProto qn) qn readInterfaceDBExtByType :: InterfaceDB -> A.QName -> IO I.TEnv readInterfaceDBExtByType db qn = - readTEnvIndex db ("ext-type " ++ show qn) (keyExtType qn) + readQNameTEnvIndex db ("ext-type " ++ show qn) (keyExtType qn) qn -readTEnvIndex :: InterfaceDB -> String -> BS.ByteString -> IO I.TEnv -readTEnvIndex db@(InterfaceDB path) label k = do +readNameTEnvIndex :: InterfaceDB -> String -> BS.ByteString -> A.Name -> IO I.TEnv +readNameTEnvIndex db label k expected = do te <- withInterfaceDBReadTxn db $ \txn dbi -> do - ns <- maybe [] id <$> getMaybeValue label txn dbi k + entry <- getMaybeValue label txn dbi k :: IO (Maybe (A.Name, [A.Name])) + ns <- case entry of + Nothing -> return [] + Just (stored,names) + | stored == expected -> return names + | otherwise -> invalidContentRow (label ++ " key/value mismatch") readNameInfoEntriesByNames txn dbi ns - traceTydbRead "index" path (label ++ " " ++ show (length te)) + traceTydbRead "index" (interfaceDBPath db) (label ++ " " ++ show (length te)) + return te + +readQNameTEnvIndex :: InterfaceDB -> String -> BS.ByteString -> A.QName -> IO I.TEnv +readQNameTEnvIndex db label k expected = do + te <- withInterfaceDBReadTxn db $ \txn dbi -> do + entry <- getMaybeValue label txn dbi k :: IO (Maybe (A.QName, [A.Name])) + ns <- case entry of + Nothing -> return [] + Just (stored,names) + | stored == stripQNameKeyLocs expected -> return names + | otherwise -> invalidContentRow (label ++ " key/value mismatch") + readNameInfoEntriesByNames txn dbi ns + traceTydbRead "index" (interfaceDBPath db) (label ++ " " ++ show (length te)) return te readNameHashEntries :: LMDB.MDB_txn -> LMDB.MDB_dbi -> IO [NameHashInfo] -readNameHashEntries txn dbi = do - vals <- getValuesWithPrefix txn dbi keyNameHashPrefix - infos <- forM (zip [0..] vals) $ \(i, v) -> - decodeStrict ("name-hash " ++ show (i :: Int)) v - return (Data.List.sortOn (A.nstr . nhName) infos) +readNameHashEntries txn dbi = + map snd <$> getRowsAt rowNameHash "all" txn dbi keyNameHashPrefix + +invalidContentRow :: String -> IO a +invalidContentRow msg = + E.throwIO (TyCacheInvalid ("Invalid .tydb content row: " ++ msg)) + +rowsIO :: Rows.RowResult a -> IO a +rowsIO result = + case result of + Left (Rows.RowError msg) -> invalidContentRow msg + Right value -> return value + +memberLabel :: A.Name -> MemberKey -> String +memberLabel owner member = A.rawstr owner ++ "." ++ Rows.memberLabel member + +topKeyLabel :: ReachRows.TopKey -> String +topKeyLabel (ReachRows.TopKey mn name) = + Data.List.intercalate "." (A.modPath mn) ++ "." ++ A.rawstr name + +memberRefLabel :: ReachRows.MemberRef -> String +memberRefLabel (ReachRows.MethodRef name) = "method:" ++ A.rawstr name +memberRefLabel (ReachRows.AttrRef name) = "attr:" ++ A.rawstr name + +-- Generic identity-validated rows ------------------------------------------------------------------------ +-- +-- Every keyed content row follows one pattern: an exact semantic key, a stored +-- copy of the identity inside the encoded row, and a payload. A RowKind +-- bundles the key builder, the wrapper codec and the label rendering; the +-- generic accessors below derive the point read, the optional read, the +-- owner-scoped enumeration, the traced session read and the write entry +-- uniformly, with one identity validation for all of them. + +data RowKind k v = RowKind + { rkLabel :: String + , rkTrace :: String + , rkName :: k -> String + , rkKey :: k -> BS.ByteString + , rkEnc :: k -> v -> BS.ByteString + , rkDec :: String -> BS.ByteString -> IO (k, v) + , rkValid :: k -> v -> Bool + } + +-- Rows are stored as the (key, payload) pair itself; the stored key copy is +-- what makes every row self-validating. Single-constructor Persist rows have +-- no constructor tag, so this is byte-identical to the previous per-row +-- wrapper types. +rowKind :: (Persist.Persist k, Persist.Persist v) + => String -> String -> (k -> String) -> (k -> BS.ByteString) -> RowKind k v +rowKind label trace name keyOf = RowKind + { rkLabel = label + , rkTrace = trace + , rkName = name + , rkKey = keyOf + , rkEnc = \k v -> encodeStrict (k, v) + , rkDec = decodeStrict + , rkValid = \_ _ -> True + } + +rowMismatch :: RowKind k v -> k -> IO a +rowMismatch kind k = + invalidContentRow (rkLabel kind ++ " key/value mismatch for " ++ rkName kind k) + +getRow :: Eq k => RowKind k v -> LMDB.MDB_txn -> LMDB.MDB_dbi -> k -> IO v +getRow kind txn dbi k = do + row <- getRowMaybe kind txn dbi k + case row of + Nothing -> E.throwIO (TyCacheInvalid + ("Missing .tydb key: " ++ rkLabel kind ++ " " ++ rkName kind k)) + Just v -> return v + +getRowMaybe :: Eq k => RowKind k v -> LMDB.MDB_txn -> LMDB.MDB_dbi -> k -> IO (Maybe v) +getRowMaybe kind txn dbi k = do + mv <- withVal (rkKey kind k) (LMDB.mdb_get txn dbi) + case mv of + Nothing -> return Nothing + Just val -> do + bytes <- copyVal val + (stored, v) <- rkDec kind (rkLabel kind ++ " " ++ rkName kind k) bytes + if stored == k && rkValid kind k v + then return (Just v) + else rowMismatch kind k + +getRowsAt :: Ord k => RowKind k v -> String -> LMDB.MDB_txn -> LMDB.MDB_dbi -> BS.ByteString -> IO [(k, v)] +getRowsAt kind ctx txn dbi prefix = do + rows <- getEntriesWithPrefix txn dbi prefix + entries <- forM (zip [0 :: Int ..] rows) $ \(i, (storedKey, bytes)) -> do + row@(stored, v) <- rkDec kind (rkLabel kind ++ " " ++ ctx ++ " #" ++ show i) bytes + unless (storedKey == rkKey kind stored && rkValid kind stored v) $ + rowMismatch kind stored + return row + let keyed = Map.fromList entries + when (length entries /= Map.size keyed) $ + invalidContentRow ("duplicate " ++ rkLabel kind ++ " rows for " ++ ctx) + return (Map.toAscList keyed) + +getOwnedRows :: (Ord a, Ord o) => RowKind (o, a) v -> (o -> String) -> (o -> BS.ByteString) + -> LMDB.MDB_txn -> LMDB.MDB_dbi -> o -> IO [(a, v)] +getOwnedRows kind name prefixOf txn dbi owner = do + entries <- getRowsAt kind (name owner) txn dbi (prefixOf owner) + forM entries $ \((stored, sub), v) -> do + unless (stored == owner) $ + invalidContentRow ("foreign " ++ rkLabel kind ++ " row for " ++ name owner) + return (sub, v) + +rowEntry :: RowKind k v -> k -> v -> (BS.ByteString, BS.ByteString) +rowEntry kind k v = (rkKey kind k, rkEnc kind k v) + +sessionRow :: Eq k => RowKind k v -> InterfaceReadSession -> k -> IO v +sessionRow kind session@(InterfaceReadSession _ txn dbi) k = do + v <- getRow kind txn dbi k + traceTydbRead (rkTrace kind) (interfaceReadSessionPath session) (rkName kind k) + return v + +sessionRowMaybe :: Eq k => RowKind k v -> InterfaceReadSession -> k -> IO (Maybe v) +sessionRowMaybe kind session@(InterfaceReadSession _ txn dbi) k = do + v <- getRowMaybe kind txn dbi k + traceTydbRead (maybe (rkTrace kind ++ "-miss") (const $ rkTrace kind) v) + (interfaceReadSessionPath session) (rkName kind k) + return v + +modNameLabel :: A.ModName -> String +modNameLabel = Data.List.intercalate "." . A.modPath + +rowContainerShape :: RowKind A.Name ContainerShape +rowContainerShape = (rowKind "shape" "shape" A.rawstr keyContainerShape) + { rkEnc = \_ shape -> encodeStrict shape + , rkDec = \ctx bytes -> do + shape <- decodeStrict ctx bytes + return (shapeName shape, shape) + } + +rowNameHash :: RowKind A.Name NameHashInfo +rowNameHash = (rowKind "name-hash" "name-hash" A.rawstr keyNameHash) + { rkEnc = \_ info -> encodeStrict (stripExternalDeps info) + , rkDec = \ctx bytes -> do + info <- decodeStrict ctx bytes + return (nhName info, info) + } + +rowMemberContent :: RowKind (A.Name, MemberKey) MemberContent +rowMemberContent = rowKind "body/member" "body-member" (uncurry memberLabel) + (uncurry keyMemberBody) + +rowReachModule :: RowKind A.ModName (ReachRows.ReachSummary, ReachRows.ReachSummary) +rowReachModule = rowKind "reach/module" "reach-module" modNameLabel keyReachModule + +rowReachTop :: RowKind ReachRows.TopKey ReachRows.TopInfo +rowReachTop = rowKind "reach/top" "reach-top" topKeyLabel keyReachTop + +rowReachMember :: RowKind (ReachRows.TopKey, MemberKey) ReachRows.MemberInfo +rowReachMember = rowKind "reach/member" "reach-member" + (\(owner, member) -> topKeyLabel owner ++ "." ++ Rows.memberLabel member) + (uncurry keyReachMember) + +rowReachShape :: RowKind ReachRows.TopKey ReachRows.ShapeInfo +rowReachShape = (rowKind "reach/shape" "reach-shape" topKeyLabel keyReachShape) + { rkValid = \owner info -> ReachRows.shapeName info == owner } + +rowReachSlot :: RowKind (ReachRows.TopKey, ReachRows.MemberRef) ReachRows.SlotInfo +rowReachSlot = rowKind "reach/slot" "reach-slot" + (\(owner, member) -> topKeyLabel owner ++ "." ++ memberRefLabel member) + (uncurry keyReachSlot) + +rowReachReflection :: RowKind ReachRows.TopKey ReachRows.ReflectableAttrs +rowReachReflection = rowKind "reach/reflection" "reach-reflection" topKeyLabel keyReachReflection + +readReachMembersEntry :: LMDB.MDB_txn -> LMDB.MDB_dbi -> ReachRows.TopKey -> IO [(MemberKey, ReachRows.MemberInfo)] +readReachMembersEntry = + getOwnedRows rowReachMember topKeyLabel (reachOwnerPrefix (key "reach/member/")) + +readReachSlotsEntry :: LMDB.MDB_txn -> LMDB.MDB_dbi -> ReachRows.TopKey -> IO [(ReachRows.MemberRef, ReachRows.SlotInfo)] +readReachSlotsEntry = + getOwnedRows rowReachSlot topKeyLabel (reachOwnerPrefix (key "reach/slot/")) + +readReachTopRowsEntry :: LMDB.MDB_txn -> LMDB.MDB_dbi -> A.ModName -> IO [(ReachRows.TopKey, ReachRows.TopInfo)] +readReachTopRowsEntry txn dbi moduleName = do + tops <- getRowsAt rowReachTop (modNameLabel moduleName) txn dbi (key "reach/top/") + forM_ tops $ \(owner@(ReachRows.TopKey storedModule _), _) -> + unless (storedModule == moduleName) $ + invalidContentRow + ("foreign reach/top row " ++ topKeyLabel owner ++ " in " ++ modNameLabel moduleName) + return tops + +readContainerEntry :: LMDB.MDB_txn -> LMDB.MDB_dbi -> A.Name -> IO A.Decl +readContainerEntry txn dbi name = do + shape <- getRow rowContainerShape txn dbi name + members <- Map.fromList <$> + getOwnedRows rowMemberContent A.rawstr keyMemberBodyPrefix txn dbi name + rowsIO (Rows.restoreExactContainer shape members) + +readSelectedContainerEntry :: LMDB.MDB_txn + -> LMDB.MDB_dbi + -> A.Name + -> Set.Set MemberKey + -> IO A.Decl +readSelectedContainerEntry txn dbi name requested = do + shape <- getRow rowContainerShape txn dbi name + members <- Map.fromList <$> mapM loadOne (Set.toAscList requested) + rowsIO (Rows.restoreSelectedContainer shape members requested) + where + loadOne member = do + content <- getRow rowMemberContent txn dbi (name, member) + return (member,content) + +restoreStoredStmt :: LMDB.MDB_txn + -> LMDB.MDB_dbi + -> Maybe (Set.Set A.Name) + -> StoredStmt + -> IO (Maybe A.Stmt) +restoreStoredStmt _ _ _ (StoredWhole _ stmt) = return (Just stmt) +restoreStoredStmt txn dbi selected (StoredDecls loc decls) = do + restored <- forM decls $ \stored -> + case stored of + StoredInline decl + | wanted (Names.dname' decl) -> return (Just decl) + | otherwise -> return Nothing + StoredContainer name + | wanted name -> Just <$> readContainerEntry txn dbi name + | otherwise -> return Nothing + case [ decl | Just decl <- restored ] of + [] -> return Nothing + kept -> return (Just (A.Decl loc kept)) + where + wanted name = maybe True (Set.member name) selected + +restoreSelectedStoredStmt :: LMDB.MDB_txn + -> LMDB.MDB_dbi + -> Set.Set A.Name + -> Map.Map A.Name (Set.Set MemberKey) + -> StoredStmt + -> IO (Maybe A.Stmt) +restoreSelectedStoredStmt _ _ _ _ (StoredWhole _ stmt) = return (Just stmt) +restoreSelectedStoredStmt txn dbi selected interests (StoredDecls loc decls) = do + restored <- forM decls $ \stored -> + case stored of + StoredInline decl + | Set.member (Names.dname' decl) selected -> return (Just decl) + | otherwise -> return Nothing + StoredContainer name + | Set.member name selected -> + Just <$> readSelectedContainerEntry txn dbi name + (Map.findWithDefault Set.empty name interests) + | otherwise -> return Nothing + case [ decl | Just decl <- restored ] of + [] -> return Nothing + kept -> return (Just (A.Decl loc kept)) + +readStoredStmtEntry :: LMDB.MDB_txn -> LMDB.MDB_dbi -> Int -> IO StoredStmt +readStoredStmtEntry txn dbi i = + getValue ("stmt " ++ show i) txn dbi (keyStmt i) readStmtEntries :: LMDB.MDB_txn -> LMDB.MDB_dbi -> IO [A.Stmt] readStmtEntries txn dbi = do count <- getValue "stmt-count" txn dbi keyStmtCount - forM [0 .. count - 1] $ \i -> - getValue ("stmt " ++ show i) txn dbi (keyStmt i) - --- | Reconstruct a typed module containing only the statements owned by the --- selected names. Returns Nothing when the cache predates statement --- ownership, when ownership is missing for a selected name, or when the --- module contains NotImplemented hooks (whose native-extension pairing needs --- the whole module); callers then fall back to a full read. -readSelectedModule :: FilePath -> [NameHashInfo] -> Set.Set A.Name -> IO (Maybe A.Module) -readSelectedModule f nameHashes selected = - withReadTxn f $ \txn dbi -> do - validateVersion txn dbi - (tmn, timps, tdoc) <- getValue "module-header" txn dbi keyModuleHeader - mHasNotImpl <- getMaybeValue "stmt-has-not-impl" txn dbi keyStmtHasNotImpl - case mHasNotImpl of - Nothing -> do - traceTydbRead "stmt-index-miss" f "stmt-has-not-impl" - return Nothing - Just True -> do - traceTydbRead "stmt-fallback" f "not-impl" - return Nothing - Just False -> do - let names = Set.toList selected - stmtMap = Map.fromList [ (nhName nh, nhStmtIndices nh) | nh <- nameHashes ] - owners = [ (n, Map.lookup n stmtMap) | n <- names ] - unusable = [ n | (n, mis) <- owners, maybe True null mis ] - if not (null unusable) - then do - traceTydbRead "stmt-index-miss" f (Data.List.intercalate "," (map A.nstr unusable)) - return Nothing - else do - -- Selected names can cover most of a large module; dedup the - -- pooled statement indices with an IntSet (O(n log n)) rather than - -- Data.List.nub (O(n^2)). toAscList also yields them sorted. - let indices = IntSet.toAscList $ IntSet.fromList $ concat [ is | (_, Just is) <- owners ] - stmts <- forM indices $ \i -> - getValue ("stmt " ++ show i) txn dbi (keyStmt i) - traceTydbRead "stmts" f ("selected " ++ show (length names) ++ " -> " ++ show (length stmts)) - return $ Just (A.Module tmn timps tdoc stmts) - -emptyExtensionIndex :: ExtensionIndex -emptyExtensionIndex = - ExtensionIndex - { extByClass = Map.empty - , extByProtocol = Map.empty - } + rows <- mapM (readStoredStmtEntry txn dbi) [0 .. count - 1] + restored <- mapM (restoreStoredStmt txn dbi Nothing) rows + return [ stmt | Just stmt <- restored ] + +-- | Materialize the exact top/member projection selected by reachability. +-- Only the requested member rows are read; method ABI +-- slots come from the compact shape, and attribute declarations remain +-- distinct from the constructor initializers activated for them. +readInterfaceSessionSelection :: InterfaceReadSession + -> [NameHashInfo] + -> Set.Set A.Name + -> Map.Map A.Name (Set.Set MemberKey) + -> IO A.Module +readInterfaceSessionSelection session@(InterfaceReadSession _ txn dbi) = + readSelectedModuleEntry (interfaceReadSessionPath session) txn dbi + +readSelectedModuleEntry :: FilePath + -> LMDB.MDB_txn + -> LMDB.MDB_dbi + -> [NameHashInfo] + -> Set.Set A.Name + -> Map.Map A.Name (Set.Set MemberKey) + -> IO A.Module +readSelectedModuleEntry f txn dbi nameHashes selected interests = do + (moduleName, imports, doc) <- getValue "module-header" txn dbi keyModuleHeader + hasNotImpl <- getValue "stmt-has-not-impl" txn dbi keyStmtHasNotImpl + mandatory <- getValue "stmt-mandatory" txn dbi keyStmtMandatory + when hasNotImpl $ + invalidModuleRows "native module requested through selective materialization" + let stmtMap = Map.fromList [ (nhName nh, nhStmtIndices nh) | nh <- nameHashes ] + owners = [ (name, Map.lookup name stmtMap) | name <- Set.toAscList selected ] + unusable = [ name | (name, indices) <- owners, maybe True null indices ] + unless (null unusable) $ + invalidModuleRows + ("selected names have no statement rows: " ++ + Data.List.intercalate ", " (map A.rawstr unusable)) + let indices = IntSet.toAscList $ IntSet.fromList $ + mandatory ++ concat [ owned | (_, Just owned) <- owners ] + stored <- mapM (readStoredStmtEntry txn dbi) indices + restored <- mapM + (restoreSelectedStoredStmt txn dbi selected interests) + stored + let statements = [ stmt | Just stmt <- restored ] + traceTydbRead "selection" f + (show (Set.size selected) ++ " tops, " ++ + show (sum (map Set.size (Map.elems interests))) ++ " members") + return (A.Module moduleName imports doc statements) extensionIndexFromNameInfo :: A.ModName -> I.NModule -> ExtensionIndex extensionIndexFromNameInfo mn (I.NModule _ te _) = - foldl addExt emptyExtensionIndex te + ExtensionIndex + { extByClass = Map.map Set.toAscList classes + , extByProtocol = Map.map Set.toAscList protocols + } where - addExt acc (ext, I.NExt _ c ps _ _ _) = + (classes,protocols) = foldl' addExt (Map.empty,Map.empty) te + + addExt (classes0,protocols0) (ext, I.NExt _ c ps _ _ _) = let cls = localQName (A.tcname c) protos = [ p | (_, pcon) <- ps, Just p <- [localQName (A.tcname pcon)] ] - withClass = - case cls of - Nothing -> acc - Just n -> acc { extByClass = insertMany n [ext] (extByClass acc) } - withProtos = - foldl - (\idx p -> idx { extByProtocol = insertMany p [ext] (extByProtocol idx) }) - withClass - protos - in withProtos - addExt acc _ = acc + classes1 = maybe classes0 (\n -> insert n ext classes0) cls + protocols1 = foldl' (\index p -> insert p ext index) protocols0 protos + in classes1 `seq` protocols1 `seq` (classes1,protocols1) + addExt indexes _ = indexes localQName qn = case qn of @@ -1118,11 +1736,7 @@ extensionIndexFromNameInfo mn (I.NModule _ te _) = A.GName m n | m == mn -> Just n _ -> Nothing - insertMany n exts = - Map.insertWith unionNames n (sortNames exts) - - unionNames xs ys = sortNames (xs ++ ys) - sortNames = Data.List.sortOn A.nstr . Data.List.nub + insert name ext = Map.insertWith Set.union name (Set.singleton ext) extensionIndexEntries :: ExtensionIndex -> [(BS.ByteString, BS.ByteString)] extensionIndexEntries index = @@ -1164,8 +1778,8 @@ stripExternalDeps :: NameHashInfo -> NameHashInfo stripExternalDeps nh = nh { nhPubDeps = [], nhImplDeps = [] } -depIndexEntries :: [DepModuleInfo] -> [NameHashInfo] -> [(BS.ByteString, BS.ByteString)] -depIndexEntries depModules nameHashes = +depIndexEntries :: [DepModuleInfo] -> [NameHashInfo] -> ModuleHashInfo -> [(BS.ByteString, BS.ByteString)] +depIndexEntries depModules nameHashes moduleHash = (keyDeps, encodeStrict depModules) : [ (keyDepModule mn, encodeStrict infos) | (mn, infos) <- moduleRows @@ -1175,11 +1789,9 @@ depIndexEntries depModules nameHashes = | ((mn, n), users) <- userRows ] where - moduleNameKey = A.modPath - nameKey = A.nstr - sortModRows = Data.List.sortOn (moduleNameKey . fst) - sortNameInfos = Data.List.sortOn (nameKey . dniName) - sortUserRows = Data.List.sortOn (\((mn, n), _) -> (moduleNameKey mn, nameKey n)) + sortModRows = Data.List.sortOn fst + sortNameInfos = Data.List.sortOn dniName + sortUserRows = Data.List.sortOn fst depTarget qn = case qn of @@ -1198,11 +1810,34 @@ depIndexEntries depModules nameHashes = else (Nothing, Just h, Set.empty, Set.singleton owner) addToEntry (Just (pubH, implH, pubUsers, implUsers)) = if isPub - then (Just h, implH, Set.insert owner pubUsers, implUsers) - else (pubH, Just h, pubUsers, Set.insert owner implUsers) + then (mergeHash "pub" qn pubH h, implH, Set.insert owner pubUsers, implUsers) + else (pubH, mergeHash "impl" qn implH h, pubUsers, Set.insert owner implUsers) + + addModuleDep isPub acc (qn, h) = + case depTarget qn of + Nothing -> acc + Just key' -> Map.alter (Just . addToEntry) key' acc + where + addToEntry Nothing = + if isPub + then (Just h, Nothing, Set.empty, Set.empty) + else (Nothing, Just h, Set.empty, Set.empty) + addToEntry (Just (pubH, implH, pubUsers, implUsers)) = + if isPub + then (mergeHash "pub" qn pubH h, implH, pubUsers, implUsers) + else (pubH, mergeHash "impl" qn implH h, pubUsers, implUsers) + + mergeHash _ _ Nothing h = Just h + mergeHash label qn (Just old) h + | old == h = Just old + | otherwise = error ("Inconsistent " ++ label ++ " dependency hashes for " ++ show qn) depMap = - foldl' addInfo Map.empty nameHashes + foldl' (addModuleDep False) + (foldl' (addModuleDep True) + (foldl' addInfo Map.empty nameHashes) + (mhPubDeps moduleHash)) + (mhImplDeps moduleHash) addInfo acc nh = let owner = nhName nh @@ -1224,7 +1859,7 @@ depIndexEntries depModules nameHashes = ] ] - cleanNames = Data.List.sortOn nameKey . Set.toList + cleanNames = Set.toList userRows = sortUserRows @@ -1281,54 +1916,148 @@ queryIndexEntries nmod = , (keyConstructors, encodeStrict (qiConstructors ix)) , (keyActors, encodeStrict (qiActors ix)) ] - ++ [ (keyConAttr n, encodeStrict ns) | (n, ns) <- Map.toList (qiConAttrs ix) ] - ++ [ (keyProtoAttr n, encodeStrict ns) | (n, ns) <- Map.toList (qiProtoAttrs ix) ] - ++ [ (keyDescendants qn, encodeStrict ns) | (qn, ns) <- Map.toList (qiDescendants ix) ] - ++ [ (keyExtProto qn, encodeStrict ns) | (qn, ns) <- Map.toList (qiExtProtos ix) ] - ++ [ (keyExtType qn, encodeStrict ns) | (qn, ns) <- Map.toList (qiExtTypes ix) ] + ++ [ (keyConAttr n, encodeStrict (n,ns)) | (n, ns) <- Map.toList (qiConAttrs ix) ] + ++ [ (keyProtoAttr n, encodeStrict (n,ns)) | (n, ns) <- Map.toList (qiProtoAttrs ix) ] + ++ [ (keyDescendants qn, encodeStrict (stripQNameKeyLocs qn,ns)) | (qn, ns) <- Map.toList (qiDescendants ix) ] + ++ [ (keyExtProto qn, encodeStrict (stripQNameKeyLocs qn,ns)) | (qn, ns) <- Map.toList (qiExtProtos ix) ] + ++ [ (keyExtType qn, encodeStrict (stripQNameKeyLocs qn,ns)) | (qn, ns) <- Map.toList (qiExtTypes ix) ] where ix = queryIndexes nmod --- Statement ownership: each top-level name records the indexes of the typed --- statements that declare it, so a statement-selective reader can fetch just --- the stmt/ rows for a selected name set. -addStmtIndices :: [A.Stmt] -> [NameHashInfo] -> [NameHashInfo] -addStmtIndices body nameHashes = +-- Statement ownership is prepared before container declarations are replaced +-- by shape references. Each top-level name records the indexes of its original +-- typed statements, preserving the existing atomicity of multi-name rows. +addStmtIndices :: [[A.Name]] -> [NameHashInfo] -> [NameHashInfo] +addStmtIndices stmtOwners nameHashes = [ nh { nhStmtIndices = Map.findWithDefault [] (nhName nh) owners } | nh <- nameHashes ] where - owners = Map.map (Data.List.sort . Data.List.nub) $ - foldl' addStmt Map.empty (zip [0..] body) - addStmt acc (i, stmt) = foldl' (\m n -> Map.insertWith (++) n [i] m) acc (stmtTopNames stmt) - -stmtTopNames :: A.Stmt -> [A.Name] -stmtTopNames stmt = - case stmt of - A.Decl _ ds -> [ Names.dname' d | d <- ds ] - A.Signature _ ns _ _ -> ns - A.Assign _ ps _ -> Data.List.nub (Names.bound ps) - A.VarAssign _ ps _ -> Data.List.nub (Names.bound ps) - _ -> [] - -interfaceEntries :: (String -> Double -> IO ()) -> [Int] -> BS.ByteString -> BS.ByteString -> BS.ByteString -> Maybe SourceFileMeta -> [(A.ModName, BS.ByteString)] -> [DepModuleInfo] -> [NameHashInfo] -> [A.Name] -> [String] -> Maybe String -> I.NModule -> A.Module -> IO [(BS.ByteString, BS.ByteString)] -interfaceEntries onProgress version moduleSrcBytesHash modulePubHash moduleImplHash sourceMeta imps depModules nameHashes roots tests mdoc nmod tchecked = do + owners = Map.map IntSet.toAscList $ + foldl' addStmt Map.empty (zip [0..] stmtOwners) + addStmt acc (i, ns) = + foldl' (\m n -> Map.insertWith IntSet.union n (IntSet.singleton i) m) acc ns + +invalidModuleRows :: String -> IO a +invalidModuleRows msg = + E.throwIO (E.ErrorCall ("Invalid prepared .tydb rows: " ++ msg)) + +validateModuleRows :: [NameHashInfo] -> InterfaceRows -> IO () +validateModuleRows nameHashes rows = do + let bodyMembers = + [ (owner, member) + | (owner, members) <- Map.toList (rowMembers rows) + , member <- Map.keys members + ] + shapeStorageKeys = map keyContainerShape (Map.keys (rowShapes rows)) + memberStorageKeys = [ keyMemberBody owner member | (owner, member) <- bodyMembers ] + when (length shapeStorageKeys /= Set.size (Set.fromList shapeStorageKeys)) $ + invalidModuleRows "semantic container shape keys collide in storage" + when (length memberStorageKeys /= Set.size (Set.fromList memberStorageKeys)) $ + invalidModuleRows "semantic member keys collide in storage" + let hashNames = Set.fromList (map nhName nameHashes) + ownerNames = Set.fromList (concatMap Rows.storedStmtNames (rowStatements rows)) + unknown = Set.toAscList (ownerNames `Set.difference` hashNames) + unless (null unknown) $ + invalidModuleRows + ("statement owners have no name hash: " ++ + Data.List.intercalate ", " (map A.rawstr unknown)) + +reachRowOwners :: ReachRows.ReachabilityRows -> [ReachRows.TopKey] +reachRowOwners rows = + Map.keys (ReachRows.reachTopRows rows) ++ + [ owner | (owner, _) <- Map.keys (ReachRows.reachMemberRows rows) ] ++ + Map.keys (ReachRows.reachShapeRows rows) ++ + [ owner | (owner, _) <- Map.keys (ReachRows.reachSlotRows rows) ] ++ + Map.keys (ReachRows.reachReflectableRows rows) + +reachStorageKeys :: A.ModName -> ReachRows.ReachabilityRows -> [BS.ByteString] +reachStorageKeys moduleName rows = + keyReachModule moduleName : + [ keyReachTop owner + | owner <- Map.keys (ReachRows.reachTopRows rows) + ] ++ + [ keyReachMember owner member + | (owner, member) <- Map.keys (ReachRows.reachMemberRows rows) + ] ++ + [ keyReachShape owner + | owner <- Map.keys (ReachRows.reachShapeRows rows) + ] ++ + [ keyReachSlot owner member + | (owner, member) <- Map.keys (ReachRows.reachSlotRows rows) + ] ++ + [ keyReachReflection owner + | owner <- Map.keys (ReachRows.reachReflectableRows rows) + ] + +validateReachabilityRows :: [NameHashInfo] + -> A.ModName + -> ReachRows.ReachabilityRows + -> IO () +validateReachabilityRows nameHashes moduleName rows = do + let owners = Set.fromList (reachRowOwners rows) + foreignOwners = + [ owner + | owner@(ReachRows.TopKey ownerModule _) <- Set.toAscList owners + , ownerModule /= moduleName + ] + knownNames = Set.fromList (map nhName nameHashes) + unknownOwners = + [ owner + | owner@(ReachRows.TopKey _ name) <- Set.toAscList owners + , not (Set.member name knownNames) + ] + storageKeys = reachStorageKeys moduleName rows + unless (null foreignOwners) $ + invalidModuleRows + ("reachability rows belong to another module: " ++ + Data.List.intercalate ", " (map topKeyLabel foreignOwners)) + unless (null unknownOwners) $ + invalidModuleRows + ("reachability owners have no name hash: " ++ + Data.List.intercalate ", " (map topKeyLabel unknownOwners)) + forM_ (Map.toList (ReachRows.reachShapeRows rows)) $ \(owner, info) -> + unless (ReachRows.shapeName info == owner) $ + invalidModuleRows ("reachability shape owner mismatch for " ++ topKeyLabel owner) + when (length storageKeys /= Set.size (Set.fromList storageKeys)) $ + invalidModuleRows "semantic reachability keys collide in storage" + +interfaceEntries :: (String -> Double -> IO ()) -> [Int] -> InterfaceContents -> IO [(BS.ByteString, BS.ByteString)] +interfaceEntries onProgress version contents = do + validateModuleRows nameHashes rows + validateReachabilityRows nameHashes (rowModuleName rows) reachRows + generation <- newInterfaceGeneration caps <- getNumCapabilities let header = [ (keyVersion, encodeStrict version) + , (keyGeneration, encodeStrict generation) , (keyMeta, encodeStrict (sourceMeta, moduleSrcBytesHash, modulePubHash, moduleImplHash)) , (keyImports, encodeStrict imps) , (keyRoots, encodeStrict roots) , (keyTests, encodeStrict tests) , (keyDoc, encodeStrict mdoc) , (keyNameCount, encodeStrict (length te)) - , (keyStmtCount, encodeStrict (length body)) - , (keyStmtHasNotImpl, encodeStrict (A.hasNotImpl body)) + , (keyStmtCount, encodeStrict (length statements)) + , (keyStmtMandatory, encodeStrict mandatoryStatementIndices) + , (keyStmtHasNotImpl, encodeStrict (rowHasNotImpl rows)) + , (keyModuleHash, encodeStrict moduleHashInfo) , (keyModuleHeader, encodeStrict (tmn, timps, tdoc)) ] nameChunks = entryChunks caps (zip [0..] te) - nameHashChunks = entryChunks caps (addStmtIndices body nameHashes) - stmtChunks = entryChunks caps (zip [0..] body) - totalPrep = 4 + length nameChunks + length nameHashChunks + length stmtChunks + nameHashChunks = entryChunks caps (addStmtIndices (map Rows.storedStmtNames statements) nameHashes) + shapeChunks = entryChunks caps (Map.elems (rowShapes rows)) + memberBodyChunks = entryChunks caps memberContents + reachTopChunks = entryChunks caps (Map.toList (ReachRows.reachTopRows reachRows)) + reachMemberChunks = entryChunks caps (Map.toList (ReachRows.reachMemberRows reachRows)) + reachShapeChunks = entryChunks caps (Map.toList (ReachRows.reachShapeRows reachRows)) + reachSlotChunks = entryChunks caps (Map.toList (ReachRows.reachSlotRows reachRows)) + reachReflectionChunks = entryChunks caps (Map.toList (ReachRows.reachReflectableRows reachRows)) + stmtChunks = entryChunks caps (zip [0..] statements) + totalPrep = 5 + length nameChunks + length nameHashChunks + + length shapeChunks + length memberBodyChunks + + length reachTopChunks + + length reachMemberChunks + + length reachShapeChunks + length reachSlotChunks + + length reachReflectionChunks + length stmtChunks prepDone <- newIORef (0 :: Int) let mark label = do done <- atomicModifyIORef' prepDone $ \n -> @@ -1337,31 +2066,89 @@ interfaceEntries onProgress version moduleSrcBytesHash modulePubHash moduleImplH onProgress "Preparing .tydb" 0 headerEntries <- forceEntries header mark "Preparing .tydb header" - depEntries <- forceEntries (depIndexEntries depModules nameHashes) + depEntries <- forceEntries (depIndexEntries depModules nameHashes moduleHashInfo) mark "Preparing .tydb deps" queryEntries <- forceEntries (queryIndexEntries nmod) mark "Preparing .tydb query indexes" + reachModuleEntries <- forceEntries + [rowEntry rowReachModule tmn + (ReachRows.reachModuleSummary reachRows, ReachRows.reachWholeSummary reachRows)] + mark "Preparing .tydb module reachability" nameEntries <- parallelEntries mark "Preparing .tydb names" nameInfoEntries nameChunks nameHashEntries <- parallelEntries mark "Preparing .tydb hashes" nameHashEntry nameHashChunks + shapeEntries <- parallelEntries mark "Preparing .tydb shapes" shapeEntry shapeChunks + memberBodyEntries <- parallelEntries mark "Preparing .tydb member bodies" memberBodyEntry memberBodyChunks + reachTopEntries <- parallelEntries mark "Preparing .tydb reachability tops" reachTopEntry reachTopChunks + reachMemberEntries <- parallelEntries mark "Preparing .tydb reachability members" reachMemberEntry reachMemberChunks + reachShapeEntries <- parallelEntries mark "Preparing .tydb reachability shapes" reachShapeEntry reachShapeChunks + reachSlotEntries <- parallelEntries mark "Preparing .tydb reachability slots" reachSlotEntry reachSlotChunks + reachReflectionEntries <- parallelEntries mark "Preparing .tydb reachability reflection" reachReflectionEntry reachReflectionChunks extEntries <- forceEntries (extensionIndexEntries (extensionIndexFromNameInfo tmn nmod)) mark "Preparing .tydb extensions" stmtEntries <- parallelEntries mark "Preparing .tydb statements" stmtEntry stmtChunks - return (headerEntries ++ depEntries ++ queryEntries ++ nameEntries ++ nameHashEntries ++ extEntries ++ stmtEntries) + return (headerEntries ++ depEntries ++ queryEntries ++ nameEntries ++ nameHashEntries + ++ shapeEntries ++ memberBodyEntries + ++ reachModuleEntries ++ reachTopEntries + ++ reachMemberEntries ++ reachShapeEntries + ++ reachSlotEntries ++ reachReflectionEntries + ++ extEntries ++ stmtEntries) where + moduleSrcBytesHash = ifcSourceHash contents + modulePubHash = ifcPublicHash contents + moduleImplHash = ifcImplementationHash contents + moduleHashInfo = ifcModuleHashInfo contents + sourceMeta = ifcSourceMeta contents + imps = ifcImports contents + depModules = ifcDependencies contents + nameHashes = ifcNameHashes contents + roots = ifcRoots contents + tests = ifcTests contents + mdoc = ifcDoc contents + nmod = ifcModule contents + rows = ifcRows contents + reachRows = ifcReachabilityRows contents I.NModule _ te _ = nmod - A.Module tmn timps tdoc body = tchecked - nameInfoEntries (i, (n, info)) = - [ (keyNameOrder i, encodeStrict suffix) - , (keyNameInfoSuffix suffix, encodeStrict (n, info)) + tmn = rowModuleName rows + timps = rowImports rows + tdoc = rowDoc rows + statements = rowStatements rows + mandatoryStatementIndices :: [Int] + mandatoryStatementIndices = + [ i + | (i, StoredWhole owners _) <- zip [0..] statements + , null owners + ] + memberContents = + [ (owner, member, content) + | (owner, members) <- Map.toList (rowMembers rows) + , (member, content) <- Map.toList members + ] + -- ModuleInfo's keyed environment, like the previous LMDB overwrite + -- layout, gives the last top-level occurrence precedence. Keep the + -- direct index identical while the ordered rows preserve every + -- signature/definition occurrence for full reconstruction. + primaryNameIndices = Map.fromListWith max + [ (name,i) | (i,(name,_)) <- zip [0..] te ] + nameInfoEntries (i, entry@(n, _)) = + [ (keyNameOrder i, encodeStrict rowKey) + , (rowKey, encodeStrict entry) + ] ++ + [ (keyNameInfo n, encodeStrict entry) + | Map.lookup n primaryNameIndices == Just i ] where - suffix = nameKeySuffix n - nameHashEntry nh = [(keyNameHash (nhName nh), encodeStrict (stripExternalDeps nh))] + rowKey = keyNameInfoOrder i + nameHashEntry nh = [rowEntry rowNameHash (nhName nh) nh] + shapeEntry shape = [rowEntry rowContainerShape (shapeName shape) shape] + memberBodyEntry (owner, member, content) = + [rowEntry rowMemberContent (owner, member) content] + reachTopEntry (owner, info) = [rowEntry rowReachTop owner info] + reachMemberEntry (ownerMember, info) = [rowEntry rowReachMember ownerMember info] + reachShapeEntry (owner, info) = [rowEntry rowReachShape owner info] + reachSlotEntry (ownerMember, info) = [rowEntry rowReachSlot ownerMember info] + reachReflectionEntry (owner, attrs) = [rowEntry rowReachReflection owner attrs] stmtEntry (i, stmt) = [(keyStmt i, encodeStrict stmt)] -writeFile :: FilePath -> BS.ByteString -> BS.ByteString -> BS.ByteString -> Maybe SourceFileMeta -> [(A.ModName, BS.ByteString)] -> [DepModuleInfo] -> [NameHashInfo] -> [A.Name] -> [String] -> Maybe String -> I.NModule -> A.Module -> IO () -writeFile = writeFileWithVersion A.version - -- | Update only the cached source-file metadata in the header, leaving every -- other row (name hashes, dep index rows, statements) untouched. Rewriting the -- whole file for a pure metadata drift would be both wasteful (the module @@ -1377,6 +2164,56 @@ updateSourceMeta f sourceMeta = do (_oldMeta, srcH, pubH, implH) <- readMeta txn dbi putValue txn dbi keyMeta (encodeStrict (sourceMeta, srcH, pubH, implH)) +-- | Update the source hash and its complete per-name dependency/hash rows +-- without rewriting typed content. The semantic name set must stay unchanged: +-- this operation deliberately updates metadata for existing content rather +-- than pretending a different module body is stored under the same interface. +updateSourceHashAndNameHashes :: FilePath + -> BS.ByteString + -> [DepModuleInfo] + -> [NameHashInfo] + -> IO () +updateSourceHashAndNameHashes f moduleSrcBytesHash depModules nameHashes = do + moduleHashInfo <- readModuleHashInfo f + update moduleHashInfo + where + update moduleHashInfo = do + validateEntryKeys (depEntries ++ nameEntries) + generation <- newInterfaceGeneration + extra <- entryMapSize (depEntries ++ nameEntries) + existing <- readMapSize f + go generation (existing + extra) + where + depPrefix = key "deps/" + depEntries = depIndexEntries depModules nameHashes moduleHashInfo + desiredDepKeys = Set.fromList + [ k | (k, _) <- depEntries, depPrefix `BS.isPrefixOf` k ] + nameEntries = + [ (keyNameHash (nhName nh), encodeStrict (stripExternalDeps nh)) + | nh <- nameHashes + ] + desiredNameKeys = Set.fromList (map fst nameEntries) + + go generation size = do + res <- E.try $ withWriteTxn f size $ \txn dbi -> do + validateVersion txn dbi + existingNameKeys <- Set.fromList <$> getKeysWithPrefix txn dbi keyNameHashPrefix + unless (existingNameKeys == desiredNameKeys) $ + invalidModuleRows "source-hash refresh changes the semantic name set" + existingDepKeys <- Set.fromList <$> getKeysWithPrefix txn dbi depPrefix + let staleDepKeys = Set.toAscList (existingDepKeys `Set.difference` desiredDepKeys) + (sourceMeta, _oldSrcH, pubH, implH) <- readMeta txn dbi + putValueIfChanged txn dbi keyMeta + (encodeStrict (sourceMeta :: Maybe SourceFileMeta, moduleSrcBytesHash, pubH, implH)) + mapM_ (deleteValue txn dbi) staleDepKeys + mapM_ (uncurry (putValueIfChanged txn dbi)) depEntries + mapM_ (uncurry (putValueIfChanged txn dbi)) nameEntries + putValue txn dbi keyGeneration (encodeStrict generation) + case res of + Right () -> return () + Left err | isMapFull err -> go generation (size * 2) + Left (err :: E.SomeException) -> E.throwIO err + -- | Apply an impl-hash refresh surgically: update the meta row, upsert the -- dependency index rows and rewrite only the per-name rows whose stored -- encoding actually changed. Everything else (module header, statements, @@ -1385,24 +2222,62 @@ updateSourceMeta f sourceMeta = do -- generated modules -- is pure waste. The dep index row KEYS are stable here -- (the module's own source is unchanged, so it depends on the same names); -- only hash values inside the rows move, hence upserting is complete. -updateImplRefresh :: FilePath -> BS.ByteString -> [DepModuleInfo] -> [NameHashInfo] -> IO () -updateImplRefresh f moduleImplHash depModules nameHashes = do - extra <- entryMapSize (depEntries ++ nameEntries) +updateImplRefresh :: FilePath -> ImplRefreshInput -> ImplRefreshOutput -> IO () +updateImplRefresh f input output = do + validateEntryKeys updatedEntries + generation <- newInterfaceGeneration + extra <- entryMapSize updatedEntries existing <- readMapSize f - go (existing + extra) + go generation (existing + extra) where - depEntries = depIndexEntries depModules nameHashes + moduleImplHash = iroImplementationHash output + moduleHashInfo = iroModuleHashInfo output + depModules = iroDependencies output + nameHashes = iroNameHashes output + updatedEntries = (keyModuleHash, encodeStrict moduleHashInfo) : depEntries ++ nameEntries + depEntries = depIndexEntries depModules nameHashes moduleHashInfo nameEntries = [ (keyNameHash (nhName nh), encodeStrict (stripExternalDeps nh)) | nh <- nameHashes ] - go size = do + go generation size = do res <- E.try $ withWriteTxn f size $ \txn dbi -> do - validateVersion txn dbi - (oldMeta, srcH, pubH, _oldImplH) <- readMeta txn dbi + (oldMeta, srcH, pubH, oldImplH) <- readMeta txn dbi + oldGeneration <- getValue "generation" txn dbi keyGeneration + unless (oldGeneration == iriGeneration input + && srcH == iriSourceHash input + && pubH == iriPublicHash input + && oldImplH == iriImplementationHash input) $ + E.throwIO (ImplRefreshStale + "Interface changed while implementation hashes were refreshed") putValue txn dbi keyMeta (encodeStrict (oldMeta :: Maybe SourceFileMeta, srcH, pubH, moduleImplHash)) + putValueIfChanged txn dbi keyModuleHash (encodeStrict moduleHashInfo) mapM_ (uncurry (putValueIfChanged txn dbi)) depEntries mapM_ (uncurry (putValueIfChanged txn dbi)) nameEntries + putValue txn dbi keyGeneration (encodeStrict generation) + case res of + Right () -> return () + Left err | isMapFull err -> go generation (size * 2) + Left (err :: E.SomeException) -> E.throwIO err + +-- | Change the cache format version and generation marker, preserving every +-- semantic content and index row. This is intentionally narrow and primarily +-- useful to verify stale-file handling without materializing and rewriting a +-- potentially huge interface. +updateVersion :: FilePath -> [Int] -> IO () +updateVersion f version = do + generation <- newInterfaceGeneration + extra <- entryMapSize [versionEntry,generationEntry generation] + existing <- readMapSize f + go generation (existing + extra) + where + versionEntry = (keyVersion, encodeStrict version) + generationEntry generation = (keyGeneration, encodeStrict generation) + go generation size = do + res <- E.try $ withWriteTxn f size $ \txn dbi -> do + validateVersion txn dbi + uncurry (putValueIfChanged txn dbi) versionEntry + uncurry (putValue txn dbi) (generationEntry generation) case res of Right () -> return () - Left err | isMapFull err -> go (size * 2) + Left err | isMapFull err -> go generation (size * 2) Left (err :: E.SomeException) -> E.throwIO err -- | Write a row only when its bytes differ from what is stored, keeping @@ -1415,13 +2290,15 @@ putValueIfChanged txn dbi k v = do Just old -> (/= v) <$> copyVal old when changed (putValue txn dbi k v) -writeFileWithVersion :: [Int] -> FilePath -> BS.ByteString -> BS.ByteString -> BS.ByteString -> Maybe SourceFileMeta -> [(A.ModName, BS.ByteString)] -> [DepModuleInfo] -> [NameHashInfo] -> [A.Name] -> [String] -> Maybe String -> I.NModule -> A.Module -> IO () -writeFileWithVersion version f moduleSrcBytesHash modulePubHash moduleImplHash sourceMeta imps depModules nameHashes roots tests mdoc nmod tchecked = - writeFileWithProgress (\_ -> return ()) version f moduleSrcBytesHash modulePubHash moduleImplHash sourceMeta imps depModules nameHashes roots tests mdoc nmod tchecked +writeFile :: (TyDbWriteProgress -> IO ()) -> FilePath -> InterfaceContents -> IO () +writeFile onProgress = writeFileVersioned onProgress A.version + +writeVersionedFile :: [Int] -> FilePath -> InterfaceContents -> IO () +writeVersionedFile = writeFileVersioned (\_ -> return ()) -writeFileWithProgress :: (TyDbWriteProgress -> IO ()) -> [Int] -> FilePath -> BS.ByteString -> BS.ByteString -> BS.ByteString -> Maybe SourceFileMeta -> [(A.ModName, BS.ByteString)] -> [DepModuleInfo] -> [NameHashInfo] -> [A.Name] -> [String] -> Maybe String -> I.NModule -> A.Module -> IO () -writeFileWithProgress onProgress version f moduleSrcBytesHash modulePubHash moduleImplHash sourceMeta imps depModules nameHashes roots tests mdoc nmod tchecked = do - entries <- interfaceEntries prepProgress version moduleSrcBytesHash modulePubHash moduleImplHash sourceMeta imps depModules nameHashes roots tests mdoc nmod tchecked +writeFileVersioned :: (TyDbWriteProgress -> IO ()) -> [Int] -> FilePath -> InterfaceContents -> IO () +writeFileVersioned onProgress version f contents = do + entries <- interfaceEntries prepProgress version contents writeProgress 0 writeEntriesWithProgress writeProgress f entries where @@ -1436,6 +2313,8 @@ readFile :: FilePath -> IO TyFile readFile f = withReadTxn f $ \txn dbi -> do (sourceMeta, moduleSrcBytesHash, modulePubHash, moduleImplHash) <- readMeta txn dbi + _mandatory <- getValue "stmt-mandatory" txn dbi keyStmtMandatory :: IO [Int] + _hasNotImpl <- getValue "stmt-has-not-impl" txn dbi keyStmtHasNotImpl :: IO Bool imps <- getValue "imports" txn dbi keyImports depModules <- getValue "deps" txn dbi keyDeps roots <- getValue "roots" txn dbi keyRoots @@ -1456,9 +2335,9 @@ readStmtHasNotImpl :: FilePath -> IO Bool readStmtHasNotImpl f = withReadTxn f $ \txn dbi -> do validateVersion txn dbi - mv <- getMaybeValue "stmt-has-not-impl" txn dbi keyStmtHasNotImpl - traceTydbRead "stmt-has-not-impl" f (show mv) - return (maybe False id mv) + hasNotImpl <- getValue "stmt-has-not-impl" txn dbi keyStmtHasNotImpl + traceTydbRead "stmt-has-not-impl" f (show hasNotImpl) + return hasNotImpl -- | Read every per-name hash row of a module (its own rows, not a -- dependency's) without touching the interface or statement rows. @@ -1470,6 +2349,16 @@ readNameHashes f = traceTydbRead "name-hash-all" f (show (length nameHashes)) return nameHashes +-- | Read the mandatory module-initialization hash component without loading +-- any typed statement or per-name hash rows. +readModuleHashInfo :: FilePath -> IO ModuleHashInfo +readModuleHashInfo f = + withReadTxn f $ \txn dbi -> do + validateVersion txn dbi + info <- getValue "module-hash" txn dbi keyModuleHash + traceTydbRead "module-hash" f "cached" + return info + -- | Read a module's interface (imports and name infos) without decoding the -- typed statement rows -- for consumers that only need the NModule, an eager -- readFile pays for deserializing the entire typed module. @@ -1477,12 +2366,21 @@ readModuleIface :: FilePath -> IO ([A.ModName], I.NModule) readModuleIface f = withReadTxn f $ \txn dbi -> do validateVersion txn dbi - mdoc <- getValue "doc" txn dbi keyDoc - (te, _nameHashes) <- readNameEntries txn dbi - (tmn, timps, tdoc) <- getValue "module-header" txn dbi keyModuleHeader + result@(_, I.NModule _ te _) <- readModuleIfaceEntries txn dbi traceTydbRead "iface" f ("names " ++ show (length te)) - let sourceImps = A.importsOf (A.Module tmn timps tdoc []) - return (sourceImps, I.NModule sourceImps te mdoc) + return result + +readModuleIfaceEntries :: LMDB.MDB_txn + -> LMDB.MDB_dbi + -> IO ([A.ModName], I.NModule) +readModuleIfaceEntries txn dbi = do + _mandatory <- getValue "stmt-mandatory" txn dbi keyStmtMandatory :: IO [Int] + _hasNotImpl <- getValue "stmt-has-not-impl" txn dbi keyStmtHasNotImpl :: IO Bool + mdoc <- getValue "doc" txn dbi keyDoc + (te, _nameHashes) <- readNameEntries txn dbi + (tmn, timps, tdoc) <- getValue "module-header" txn dbi keyModuleHeader + let sourceImps = A.importsOf (A.Module tmn timps tdoc []) + return (sourceImps, I.NModule sourceImps te mdoc) -- Read only cached header fields from .tydb. This avoids decoding the large -- NameInfo and typed Module statement sections and is much faster than readFile @@ -1496,6 +2394,8 @@ readHeader f = roots <- getValue "roots" txn dbi keyRoots tests <- getValue "tests" txn dbi keyTests doc <- getValue "doc" txn dbi keyDoc + _mandatory <- getValue "stmt-mandatory" txn dbi keyStmtMandatory :: IO [Int] + _hasNotImpl <- getValue "stmt-has-not-impl" txn dbi keyStmtHasNotImpl :: IO Bool nameHashes <- readNameHashEntries txn dbi traceTydbRead "header" f "cached" traceTydbRead "name-hash-all" f (show (length nameHashes)) @@ -1513,6 +2413,8 @@ readHeaderSummary f = tests <- getValue "tests" txn dbi keyTests doc <- getValue "doc" txn dbi keyDoc nameCount <- getValue "name-count" txn dbi keyNameCount + _mandatory <- getValue "stmt-mandatory" txn dbi keyStmtMandatory :: IO [Int] + _hasNotImpl <- getValue "stmt-has-not-impl" txn dbi keyStmtHasNotImpl :: IO Bool traceTydbRead "header" f "cached" return (sourceMeta, moduleSrcBytesHash, modulePubHash, moduleImplHash, imps, depModules, nameCount, roots, tests, doc) @@ -1526,52 +2428,185 @@ readDepNames :: FilePath -> A.ModName -> IO [DepNameInfo] readDepNames f mn = withReadTxn f $ \txn dbi -> do validateVersion txn dbi - mDeps <- getMaybeValue ("deps/" ++ Data.List.intercalate "." (A.modPath mn)) txn dbi (keyDepModule mn) - let deps = maybe [] id mDeps + deps <- readDepNameEntries txn dbi mn traceTydbRead "dep-names" f (Data.List.intercalate "." (A.modPath mn) ++ " " ++ show (length deps)) return deps +readDepNameEntries :: LMDB.MDB_txn -> LMDB.MDB_dbi -> A.ModName -> IO [DepNameInfo] +readDepNameEntries txn dbi mn = do + mDeps <- getMaybeValue + ("deps/" ++ Data.List.intercalate "." (A.modPath mn)) + txn dbi (keyDepModule mn) + return (maybe [] id mDeps) + readDepUsers :: FilePath -> A.ModName -> A.Name -> IO DepUsers readDepUsers f mn n = withReadTxn f $ \txn dbi -> do validateVersion txn dbi - mUsers <- getMaybeValue ("deps/" ++ Data.List.intercalate "." (A.modPath mn) ++ "/" ++ A.rawstr n) txn dbi (keyDepName mn n) + users <- readDepUsersEntry txn dbi mn n traceTydbRead "dep-users" f (Data.List.intercalate "." (A.modPath mn) ++ "." ++ A.rawstr n) - return (maybe emptyDepUsers id mUsers) + return users + +readDepUsersEntry :: LMDB.MDB_txn -> LMDB.MDB_dbi -> A.ModName -> A.Name -> IO DepUsers +readDepUsersEntry txn dbi mn n = do + mUsers <- getMaybeValue + ("deps/" ++ Data.List.intercalate "." (A.modPath mn) ++ "/" ++ A.rawstr n) + txn dbi (keyDepName mn n) + return (maybe emptyDepUsers id mUsers) readNameHash :: FilePath -> A.Name -> IO (Maybe NameHashInfo) readNameHash f n = withReadTxn f $ \txn dbi -> do validateVersion txn dbi - mInfo <- getMaybeValue ("name-hash/" ++ A.rawstr n) txn dbi (keyNameHash n) + mInfo <- readNameHashEntry txn dbi n traceTydbRead (case mInfo of { Just _ -> "name-hash"; Nothing -> "name-hash-miss" }) f (A.rawstr n) return mInfo +readNameHashEntry :: LMDB.MDB_txn -> LMDB.MDB_dbi -> A.Name -> IO (Maybe NameHashInfo) +readNameHashEntry = getRowMaybe rowNameHash + readNameHashMaybe :: FilePath -> A.Name -> IO (Maybe NameHashInfo) readNameHashMaybe f n = readNameHash f n `E.catch` tyCacheMiss +readInterfaceSessionNameHashMaybe :: InterfaceReadSession + -> A.Name + -> IO (Maybe NameHashInfo) +readInterfaceSessionNameHashMaybe session@(InterfaceReadSession _ txn dbi) n = do + mInfo <- readNameHashEntry txn dbi n + traceTydbRead (case mInfo of { Just _ -> "name-hash"; Nothing -> "name-hash-miss" }) + (interfaceReadSessionPath session) (A.rawstr n) + return mInfo + +readMemberContent :: FilePath -> A.Name -> MemberKey -> IO MemberContent +readMemberContent f owner member = + withReadTxn f $ \txn dbi -> do + validateVersion txn dbi + content <- getRow rowMemberContent txn dbi (owner, member) + traceTydbRead "body-member" f (memberLabel owner member) + return content + +readInterfaceSessionReachSummaries :: InterfaceReadSession + -> A.ModName + -> IO (ReachRows.ReachSummary, ReachRows.ReachSummary) +readInterfaceSessionReachSummaries = sessionRow rowReachModule + +readInterfaceSessionReachTop :: InterfaceReadSession + -> ReachRows.TopKey + -> IO ReachRows.TopInfo +readInterfaceSessionReachTop = sessionRow rowReachTop + +readInterfaceSessionReachTopMaybe :: InterfaceReadSession + -> ReachRows.TopKey + -> IO (Maybe ReachRows.TopInfo) +readInterfaceSessionReachTopMaybe = sessionRowMaybe rowReachTop + +readInterfaceSessionReachMemberMaybe :: InterfaceReadSession + -> ReachRows.TopKey + -> MemberKey + -> IO (Maybe ReachRows.MemberInfo) +readInterfaceSessionReachMemberMaybe session owner member = + sessionRowMaybe rowReachMember session (owner, member) + +readInterfaceSessionReachShapeMaybe :: InterfaceReadSession + -> ReachRows.TopKey + -> IO (Maybe ReachRows.ShapeInfo) +readInterfaceSessionReachShapeMaybe = sessionRowMaybe rowReachShape + +readInterfaceSessionReachSlotMaybe :: InterfaceReadSession + -> ReachRows.TopKey + -> ReachRows.MemberRef + -> IO (Maybe ReachRows.SlotInfo) +readInterfaceSessionReachSlotMaybe session owner member = + sessionRowMaybe rowReachSlot session (owner, member) + +readInterfaceSessionReachSlots :: InterfaceReadSession + -> ReachRows.TopKey + -> IO [(ReachRows.MemberRef, ReachRows.SlotInfo)] +readInterfaceSessionReachSlots session@(InterfaceReadSession _ txn dbi) owner = do + slots <- readReachSlotsEntry txn dbi owner + traceTydbRead "reach-slots" (interfaceReadSessionPath session) (topKeyLabel owner) + return slots + +readInterfaceSessionReachReflectionMaybe :: InterfaceReadSession + -> ReachRows.TopKey + -> IO (Maybe ReachRows.ReflectableAttrs) +readInterfaceSessionReachReflectionMaybe = sessionRowMaybe rowReachReflection + +-- | Read the persisted reachability analysis for a module or one exact +-- top-level name. This is an explicit inspection path; normal selection keeps +-- using the exact-key readers above and never enumerates unrelated rows. +readReachabilityRows :: FilePath + -> A.ModName + -> Maybe A.Name + -> IO ReachRows.ReachabilityRows +readReachabilityRows f moduleName target = + withReadTxn f $ \txn dbi -> do + validateVersion txn dbi + (moduleSummary,wholeSummary) <- getRow rowReachModule txn dbi moduleName + tops <- case target of + Nothing -> readReachTopRowsEntry txn dbi moduleName + Just name -> do + let owner = ReachRows.TopKey moduleName name + info <- getRowMaybe rowReachTop txn dbi owner + return [ (owner,found) | Just found <- [info] ] + let owners = map fst tops + members <- fmap concat $ forM owners $ \owner -> do + entries <- readReachMembersEntry txn dbi owner + return [ ((owner,member),info) | (member,info) <- entries ] + shapes <- forM owners $ \owner -> do + info <- getRowMaybe rowReachShape txn dbi owner + return [ (owner,found) | Just found <- [info] ] + slots <- fmap concat $ forM owners $ \owner -> do + entries <- readReachSlotsEntry txn dbi owner + return [ ((owner,member),info) | (member,info) <- entries ] + reflected <- forM owners $ \owner -> do + attrs <- getRowMaybe rowReachReflection txn dbi owner + return [ (owner,found) | Just found <- [attrs] ] + traceTydbRead "reachability" f + (Data.List.intercalate "." (A.modPath moduleName) ++ + maybe "" (("." ++) . A.rawstr) target) + return ReachRows.ReachabilityRows + { ReachRows.reachModuleSummary = moduleSummary + , ReachRows.reachWholeSummary = wholeSummary + , ReachRows.reachTopRows = Map.fromList tops + , ReachRows.reachMemberRows = Map.fromList members + , ReachRows.reachShapeRows = Map.fromList (concat shapes) + , ReachRows.reachSlotRows = Map.fromList slots + , ReachRows.reachReflectableRows = Map.fromList (concat reflected) + } + readModuleHashesMaybe :: FilePath -> IO (Maybe (BS.ByteString, BS.ByteString, BS.ByteString)) readModuleHashesMaybe = readTyMaybe readModuleHashes +readInterfaceSummaryMaybe :: FilePath -> IO (Maybe InterfaceSummary) +readInterfaceSummaryMaybe = + readTyMaybe readInterfaceSummary + readExtensionsByClass :: FilePath -> A.Name -> IO [A.Name] readExtensionsByClass f n = withReadTxn f $ \txn dbi -> do validateVersion txn dbi entry <- getMaybeValue "ext-by-class" txn dbi (keyExtByClass n) :: IO (Maybe (A.Name, [A.Name])) - return $ case entry of - Nothing -> [] - Just (_, exts) -> exts + case entry of + Nothing -> return [] + Just (stored, exts) + | stored == n -> return exts + | otherwise -> invalidContentRow + ("ext-by-class key/value mismatch for " ++ A.rawstr n) readExtensionsByProtocol :: FilePath -> A.Name -> IO [A.Name] readExtensionsByProtocol f n = withReadTxn f $ \txn dbi -> do validateVersion txn dbi entry <- getMaybeValue "ext-by-protocol" txn dbi (keyExtByProtocol n) :: IO (Maybe (A.Name, [A.Name])) - return $ case entry of - Nothing -> [] - Just (_, exts) -> exts + case entry of + Nothing -> return [] + Just (stored, exts) + | stored == n -> return exts + | otherwise -> invalidContentRow + ("ext-by-protocol key/value mismatch for " ++ A.rawstr n) -- Interface files are caches for most callers. If a file is missing, -- unreadable, corrupt, or from a different compiler interface version, the diff --git a/compiler/lib/test/9-codegen/boxparam.c b/compiler/lib/test/9-codegen/boxparam.c index ee7bd9be0..1ab9965dc 100644 --- a/compiler/lib/test/9-codegen/boxparam.c +++ b/compiler/lib/test/9-codegen/boxparam.c @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #include "rts/common.h" #include "out/types/boxparam.h" B_value boxparamQ_BaseD___get_attr__ (boxparamQ_Base self, B_str name) { diff --git a/compiler/lib/test/9-codegen/boxparam.h b/compiler/lib/test/9-codegen/boxparam.h index 9d6a9ac43..d18e30c5f 100644 --- a/compiler/lib/test/9-codegen/boxparam.h +++ b/compiler/lib/test/9-codegen/boxparam.h @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #pragma once #include "builtin/builtin.h" #include "rts/rts.h" diff --git a/compiler/lib/test/9-codegen/chunking.c b/compiler/lib/test/9-codegen/chunking.c index cb82ebafc..aa86a63e4 100644 --- a/compiler/lib/test/9-codegen/chunking.c +++ b/compiler/lib/test/9-codegen/chunking.c @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #include "rts/common.h" #include "out/types/chunking.h" int64_t chunkingQ_c000; diff --git a/compiler/lib/test/9-codegen/chunking.h b/compiler/lib/test/9-codegen/chunking.h index 8599db434..c68197c8d 100644 --- a/compiler/lib/test/9-codegen/chunking.h +++ b/compiler/lib/test/9-codegen/chunking.h @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #pragma once #include "builtin/builtin.h" #include "rts/rts.h" diff --git a/compiler/lib/test/9-codegen/deact.c b/compiler/lib/test/9-codegen/deact.c index be2e2e2bc..d87dd5aa9 100644 --- a/compiler/lib/test/9-codegen/deact.c +++ b/compiler/lib/test/9-codegen/deact.c @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #include "rts/common.h" #include "out/types/deact.h" $R deactQ_L_1C_1cont ($Cont C_cont, B_NoneType C_2res) { diff --git a/compiler/lib/test/9-codegen/deact.h b/compiler/lib/test/9-codegen/deact.h index 43358a41e..ed70543df 100644 --- a/compiler/lib/test/9-codegen/deact.h +++ b/compiler/lib/test/9-codegen/deact.h @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #pragma once #include "builtin/builtin.h" #include "rts/rts.h" diff --git a/compiler/lib/test/9-codegen/ints.c b/compiler/lib/test/9-codegen/ints.c index 39aa7deae..4e15fd8c0 100644 --- a/compiler/lib/test/9-codegen/ints.c +++ b/compiler/lib/test/9-codegen/ints.c @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #include "rts/common.h" #include "out/types/ints.h" int64_t intsQ_int64_min; diff --git a/compiler/lib/test/9-codegen/ints.h b/compiler/lib/test/9-codegen/ints.h index 37eafc615..e4075e1a7 100644 --- a/compiler/lib/test/9-codegen/ints.h +++ b/compiler/lib/test/9-codegen/ints.h @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #pragma once #include "builtin/builtin.h" #include "rts/rts.h" diff --git a/compiler/lib/test/9-codegen/lines.c b/compiler/lib/test/9-codegen/lines.c index 8ad60a8b3..6b83bfd8d 100644 --- a/compiler/lib/test/9-codegen/lines.c +++ b/compiler/lib/test/9-codegen/lines.c @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #include "rts/common.h" #include "out/types/lines.h" B_Eq linesQ_W_Apa_1097; diff --git a/compiler/lib/test/9-codegen/lines.h b/compiler/lib/test/9-codegen/lines.h index e570f9406..3a50d85ed 100644 --- a/compiler/lib/test/9-codegen/lines.h +++ b/compiler/lib/test/9-codegen/lines.h @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #pragma once #include "builtin/builtin.h" #include "rts/rts.h" diff --git a/compiler/lib/test/9-codegen/witness_forward.c b/compiler/lib/test/9-codegen/witness_forward.c index 76c9b3cbe..44f37c528 100644 --- a/compiler/lib/test/9-codegen/witness_forward.c +++ b/compiler/lib/test/9-codegen/witness_forward.c @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #include "rts/common.h" #include "out/types/witness_forward.h" B_NoneType witness_forwardQ_PAD___init__ (witness_forwardQ_PA W_self) { diff --git a/compiler/lib/test/9-codegen/witness_forward.h b/compiler/lib/test/9-codegen/witness_forward.h index b44a95501..a2859c5bc 100644 --- a/compiler/lib/test/9-codegen/witness_forward.h +++ b/compiler/lib/test/9-codegen/witness_forward.h @@ -1,4 +1,4 @@ -/* Acton impl hash: test-hash */ +/* Acton codegen hash: test-hash */ #pragma once #include "builtin/builtin.h" #include "rts/rts.h" From 1f5b3b9abbd8b2b4211eb2c4e4c90089d69ce458 Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Tue, 18 Aug 2026 17:32:32 +0200 Subject: [PATCH 5/9] Render persisted reachability rows Add a deterministic pretty-printer for the reachability rows of one module or one top-level name, plus a reader that loads exactly those rows, so the persisted dependency facts can be inspected and compared in tests. The --reachability flag on acton sig is defined here; the command wiring arrives with the scheduler, which also renders the closed project selection. --- compiler/lib/package.yaml.in | 1 + compiler/lib/src/Acton/CommandLineParser.hs | 12 +- compiler/lib/src/Acton/ReachabilityPrinter.hs | 243 ++++++++++++++++++ 3 files changed, 252 insertions(+), 4 deletions(-) create mode 100644 compiler/lib/src/Acton/ReachabilityPrinter.hs diff --git a/compiler/lib/package.yaml.in b/compiler/lib/package.yaml.in index e82e86d03..fe2db1c84 100644 --- a/compiler/lib/package.yaml.in +++ b/compiler/lib/package.yaml.in @@ -91,6 +91,7 @@ library: - Acton.Printer - Acton.QuickType - Acton.Reachability + - Acton.ReachabilityPrinter - Acton.ReachabilityRows - Acton.Solver - Acton.SourceProvider diff --git a/compiler/lib/src/Acton/CommandLineParser.hs b/compiler/lib/src/Acton/CommandLineParser.hs index 9512c23b2..a3cbecafd 100644 --- a/compiler/lib/src/Acton/CommandLineParser.hs +++ b/compiler/lib/src/Acton/CommandLineParser.hs @@ -121,8 +121,9 @@ data UninstallOptions = UninstallOptions } deriving Show data SigOptions = SigOptions - { sigCompile :: CompileOptions - , sigTarget :: String + { sigCompile :: CompileOptions + , sigReachability :: Bool + , sigTarget :: Maybe String } deriving Show @@ -213,7 +214,7 @@ cmdLineParser = hsubparser <> command "build" (info (CmdOpt <$> globalOptions <*> (Build <$> buildOptions)) (progDesc "Build an Acton project")) <> command "install" (info (CmdOpt <$> globalOptions <*> (Install <$> installOptions)) (progDesc "Install an Acton application package")) <> command "uninstall" (info (CmdOpt <$> globalOptions <*> (Uninstall <$> uninstallOptions)) (progDesc "Uninstall an Acton application package")) - <> command "sig" (info (CmdOpt <$> globalOptions <*> (Sig <$> sigOptions)) (progDesc "Show inferred type signatures")) + <> command "sig" (info (CmdOpt <$> globalOptions <*> (Sig <$> sigOptions)) (progDesc "Show inferred signatures or reachability")) <> command "test" (info (CmdOpt <$> globalOptions <*> (Test <$> testCommand)) (progDesc "Build and run project tests")) <> command "repl" (info (CmdOpt <$> globalOptions <*> (Repl <$> compileOptions)) (progDesc "Run an interactive Acton shell")) <> command "fetch" (info (CmdOpt <$> globalOptions <*> pure Fetch) (progDesc "Fetch project dependencies (offline prep)")) @@ -298,7 +299,10 @@ uninstallOptions = sigOptions :: Parser SigOptions sigOptions = SigOptions <$> sigCompileOptions - <*> argument str (metavar "TARGET" <> help "Module or module.name to show, e.g. foo.bar") + <*> switch (long "reachability" <> help "Show the project selection or cached module reachability") + <*> optional (argument str + (metavar "TARGET" <> + help "Module or module.name; omit with --reachability for the project")) sigCompileOptions :: Parser CompileOptions sigCompileOptions = mkSigCompileOptions diff --git a/compiler/lib/src/Acton/ReachabilityPrinter.hs b/compiler/lib/src/Acton/ReachabilityPrinter.hs new file mode 100644 index 000000000..8ea8e8b67 --- /dev/null +++ b/compiler/lib/src/Acton/ReachabilityPrinter.hs @@ -0,0 +1,243 @@ +-- SPDX-License-Identifier: BSD-3-Clause + +-- | Human-readable views of reachability information. +-- +-- 'prettyRows' shows the dependency rows recorded in one TYDB interface; +-- 'prettySelection' shows the closed set selected for a whole project. The +-- former is produced by 'prepareReachabilityRows' and the latter by +-- 'selectProgram'. These renderings are used by @acton sig +-- --reachability@ and contain no analysis or selection logic of their own. +module Acton.ReachabilityPrinter (prettySelection, prettyRows) where + +import Prelude hiding ((<>)) + +import qualified Acton.InterfaceRows as Rows +import qualified Acton.Reachability as Reachability +import qualified Acton.ReachabilityRows as ReachRows +import qualified Acton.Syntax as A + +import Data.List (intercalate) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Pretty + + +-- Closed selection -------------------------------------------------------------------------------------- + +prettySelection :: Set.Set A.ModName -> Reachability.Selection -> String +prettySelection whole selection = render $ + text "reachability" $+$ nest 2 (vcatOrNone $ map prettyModule modules) + where + modules = Set.toAscList $ whole `Set.union` Map.keysSet keysByModule + selectedKeys = Set.unions + [ Reachability.selectedDeclarations selection + , Reachability.selectedTops selection + , Reachability.selectedOpaqueTops selection + , Set.map fst $ Reachability.selectedMembers selection + , Set.map fst $ Reachability.selectedAttrs selection + , Set.map fst $ Reachability.selectedStaticInitializers selection + , Set.map fst $ Reachability.selectedInstanceInitializers selection + , Set.map fst $ Reachability.selectedGenerated selection + , Reachability.selectedConstructed selection + , Reachability.selectedInitialized selection + ] + keysByModule = Set.foldl' addKey Map.empty selectedKeys + addKey byModule key@(ReachRows.TopKey mn _) = + Map.insertWith Set.union mn (Set.singleton key) byModule + + membersByTop = groupSet $ Reachability.selectedMembers selection + attrsByTop = groupSet $ Reachability.selectedAttrs selection + staticInitializersByTop = groupSet $ Reachability.selectedStaticInitializers selection + instanceInitializersByTop = groupSet $ Reachability.selectedInstanceInitializers selection + generatedByTop = groupSet $ Reachability.selectedGenerated selection + + prettyModule mn = + let keys = Set.toAscList $ Map.findWithDefault Set.empty mn keysByModule + header = text "module" <+> prettyModuleName mn <> + flags [ "whole" | Set.member mn whole ] + in header $+$ nest 2 (vcat $ map prettyTop keys) + + prettyTop key@(ReachRows.TopKey _ name) = + let topFlags = + [ "declaration" | Set.member key $ Reachability.selectedDeclarations selection ] ++ + [ "body" | Set.member key $ Reachability.selectedTops selection ] ++ + [ "opaque" | Set.member key $ Reachability.selectedOpaqueTops selection ] ++ + [ "constructed" | Set.member key $ Reachability.selectedConstructed selection ] ++ + [ "initialized" | Set.member key $ Reachability.selectedInitialized selection ] + members = Map.findWithDefault Set.empty key membersByTop + selectedAttrs = Map.findWithDefault Set.empty key attrsByTop + staticInitializers = Map.findWithDefault Set.empty key staticInitializersByTop + instanceInitializers = Map.findWithDefault Set.empty key instanceInitializersByTop + generated = Map.findWithDefault Set.empty key generatedByTop + attrs = Set.toAscList $ Set.fromList + ([ n | Rows.Attr n <- Set.toAscList members ] ++ + Set.toAscList selectedAttrs ++ + Set.toAscList staticInitializers ++ + Set.toAscList instanceInitializers ++ + [ n | ReachRows.AttrRef n <- Set.toAscList generated ]) + methods = Set.toAscList $ Set.fromList + ([ n | Rows.Method n <- Set.toAscList members ] ++ + [ n | ReachRows.MethodRef n <- Set.toAscList generated ]) + constructor = Set.member Rows.InitRest members + memberDocs = + [ text "constructor" <> flags ["body"] | constructor ] ++ + map (prettyAttr members selectedAttrs staticInitializers + instanceInitializers generated) attrs ++ + map (prettyMethod members generated) methods + in text (A.rawstr name) <> flags topFlags $+$ nest 2 (vcat memberDocs) + + prettyAttr members selectedAttrs staticInitializers instanceInitializers generated name = + text "attr" <+> text (A.rawstr name) <> flags + ([ "declaration" | Set.member (Rows.Attr name) members ] ++ + [ "used" | Set.member name selectedAttrs ] ++ + [ "static initializer" | Set.member name staticInitializers ] ++ + [ "instance initializer" | Set.member name instanceInitializers ] ++ + [ "generated" | Set.member (ReachRows.AttrRef name) generated ]) + + prettyMethod members generated name = + text "method" <+> text (A.rawstr name) <> flags + ([ "body" | Set.member (Rows.Method name) members ] ++ + [ "generated" | Set.member (ReachRows.MethodRef name) generated ]) + + +-- Persisted analysis ------------------------------------------------------------------------------------ + +prettyRows :: A.ModName -> Maybe A.Name -> ReachRows.ReachabilityRows -> String +prettyRows moduleName target rows = render $ + text "reachability in" <+> prettyModuleName moduleName $+$ + nest 2 (vcat $ moduleDocs ++ map prettyTop (Map.toAscList $ ReachRows.reachTopRows rows)) + where + membersByTop = groupMap $ ReachRows.reachMemberRows rows + slotsByTop = groupMap $ ReachRows.reachSlotRows rows + + moduleDocs = case target of + Just _ -> [] + Nothing -> + [ summary "module initialization" (ReachRows.reachModuleSummary rows) + , summary "whole module" (ReachRows.reachWholeSummary rows) + ] + + prettyTop (key@(ReachRows.TopKey _ name),info) = + let mShape = Map.lookup key (ReachRows.reachShapeRows rows) + heading = maybe (text "name") (text . shapeLabel . ReachRows.shapeKind) mShape <+> + text (A.rawstr name) <> flags [ "opaque" | ReachRows.OpaqueTop{} <- [info] ] + body = case info of + ReachRows.LocalTop _ dependencies -> dependencies + ReachRows.OpaqueTop dependencies -> dependencies + members = Map.toAscList $ Map.findWithDefault Map.empty key membersByTop + slots = Map.toAscList $ Map.findWithDefault Map.empty key slotsByTop + reflection = Map.lookup key (ReachRows.reachReflectableRows rows) + details = [summary "dependencies" body] ++ + maybe [] (pure . prettyShape) mShape ++ + map prettyMember members ++ map prettySlot slots ++ + maybe [] prettyReflection reflection + in heading $+$ nest 2 (vcat details) + + prettyShape shape = vcat $ + [ text "lineage:" <+> commaSep prettyTopKey (ReachRows.shapeLineage shape) ] ++ + maybe [] (pure . prettyConstructor) (ReachRows.shapeConstructor shape) ++ + [ text "abstract:" <+> commaSep prettyMemberRef (ReachRows.shapeAbstracts shape) + | not (null $ ReachRows.shapeAbstracts shape) + ] + + prettyConstructor (provider,constructor) = + let (kind,dependencies) = case constructor of + ReachRows.StoredConstructor deps -> ("stored",Just deps) + ReachRows.GeneratedConstructor deps -> ("generated",Just deps) + ReachRows.InheritedConstructor deps -> ("inherited",Just deps) + ReachRows.OpaqueConstructor -> ("opaque",Nothing) + heading = text "constructor:" <+> prettyTopKey provider <> flags [kind] + in heading $+$ nest 2 (maybe empty (summary "dependencies") dependencies) + + prettyMember (member,info) = + let label = case member of + Rows.Method name -> text "method" <+> text (A.rawstr name) + Rows.Attr name -> text "attr" <+> text (A.rawstr name) + Rows.StaticInit name -> text "static initializer" <+> text (A.rawstr name) + Rows.InstanceInit name -> text "instance initializer" <+> text (A.rawstr name) + Rows.InitRest -> text "constructor body" + bodyLabel = case member of + Rows.Attr{} -> "declaration dependencies" + _ -> "dependencies" + details = [summary bodyLabel $ ReachRows.memberSummary info] ++ + maybe [] (pure . summary "static initializer") + (ReachRows.memberStaticInitSummary info) ++ + maybe [] (pure . summary "instance initializer") + (ReachRows.memberInstanceInitSummary info) + in label $+$ nest 2 (vcat details) + + prettySlot (ref,slot) = + let provider = ReachRows.slotProvider slot + (kind,dependencies) = case ReachRows.slotDecl slot of + ReachRows.StoredSlot member -> ("stored " ++ memberKeyLabel member,Nothing) + ReachRows.AttributeSlot -> ("attribute",Nothing) + ReachRows.AbstractSlot -> ("abstract",Nothing) + ReachRows.OpaqueSlot -> ("opaque",Nothing) + heading = text "slot" <+> prettyMemberRef ref <+> text "->" <+> prettyTopKey provider <> flags [kind] + in heading $+$ nest 2 (maybe empty (summary "dependencies") dependencies) + + prettyReflection (ReachRows.ReflectableAttrs []) = [] + prettyReflection (ReachRows.ReflectableAttrs attrs) + = [text "reflectable attrs:" <+> commaSep (text . A.rawstr) attrs] + + +-- Shared presentation ---------------------------------------------------------------------------------- + +summary :: String -> ReachRows.ReachSummary -> Doc +summary label dependencies = + text label <> colon $+$ nest 2 (vcatOrNone $ map prettyEdge $ ReachRows.reachEdges dependencies) + +prettyEdge :: ReachRows.ReachEdge -> Doc +prettyEdge edge = case edge of + ReachRows.Declare mn name -> text "declare" <+> prettyName mn name + ReachRows.Need mn name -> text "need" <+> prettyName mn name + ReachRows.Construct mn name -> text "construct" <+> prettyName mn name + ReachRows.Direct mn name ref -> text "direct" <+> prettyName mn name <> dot <> prettyMemberRef ref + ReachRows.Dispatch mn name ref -> text "dispatch" <+> prettyName mn name <> dot <> prettyMemberRef ref + ReachRows.Reflect mn name -> text "reflect" <+> prettyName mn name + ReachRows.DynamicSerialization -> text "dynamic serialization" + ReachRows.DeclareAttr mn name attr -> text "declare attr" <+> prettyName mn name <> dot <> text (A.rawstr attr) + +prettyTopKey :: ReachRows.TopKey -> Doc +prettyTopKey (ReachRows.TopKey mn name) = prettyName mn name + +prettyName :: A.ModName -> A.Name -> Doc +prettyName mn name = prettyModuleName mn <> dot <> text (A.rawstr name) + +prettyModuleName :: A.ModName -> Doc +prettyModuleName = text . intercalate "." . A.modPath + +prettyMemberRef :: ReachRows.MemberRef -> Doc +prettyMemberRef (ReachRows.MethodRef name) = text "method" <+> text (A.rawstr name) +prettyMemberRef (ReachRows.AttrRef name) = text "attr" <+> text (A.rawstr name) + +memberKeyLabel :: Rows.MemberKey -> String +memberKeyLabel (Rows.Method name) = "method " ++ A.rawstr name +memberKeyLabel (Rows.Attr name) = "attr " ++ A.rawstr name +memberKeyLabel (Rows.StaticInit name) = "static initializer " ++ A.rawstr name +memberKeyLabel (Rows.InstanceInit name) = "instance initializer " ++ A.rawstr name +memberKeyLabel Rows.InitRest = "constructor body" + +shapeLabel :: ReachRows.ShapeKind -> String +shapeLabel ReachRows.ClassShape = "class" +shapeLabel ReachRows.ActorShape = "actor" +shapeLabel ReachRows.WitnessShape = "witness" +shapeLabel ReachRows.ProtocolShape = "protocol" + +flags :: [String] -> Doc +flags [] = empty +flags xs = space <> brackets (commaSep text xs) + +vcatOrNone :: [Doc] -> Doc +vcatOrNone [] = text "none" +vcatOrNone ds = vcat ds + +groupSet :: (Ord owner, Ord item) => Set.Set (owner,item) -> Map.Map owner (Set.Set item) +groupSet = Set.foldl' add Map.empty + where + add groups (owner,item) = Map.insertWith Set.union owner (Set.singleton item) groups + +groupMap :: (Ord owner, Ord item) => Map.Map (owner,item) value -> Map.Map owner (Map.Map item value) +groupMap = Map.foldlWithKey' add Map.empty + where + add groups (owner,item) value = Map.insertWith Map.union owner (Map.singleton item value) groups From 7e14e35e2bffa257a201389b9cfc995fbcdb5d05 Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Tue, 18 Aug 2026 17:32:44 +0200 Subject: [PATCH 6/9] Select and materialize back-pass projections Close the program roots over persisted reachability rows with a worklist that reads only exact keys: a needed top-level name pulls its summary and its class shape, a member edge resolves to the slot's effective provider and pulls that member's row, a construction pulls the constructor and the initializer groups of every attribute the program reads, and reflection retains every reflectable attribute of every constructed subclass. Inherited attribute declarations are kept for layout even when their initialization is not, so a partially rendered class keeps the field prefix of its ancestors. Materialize the selection into partial modules for the ordinary back pipeline: restore only the selected syntax rows from each interface, project imports to the retained names while keeping an emptied import so the provider's module initialization still runs, and install declaration-only bindings for classes that are referenced but not rendered. Missing, ambiguous or abstract targets are errors; the projection is never widened. --- compiler/lib/package.yaml.in | 1 + compiler/lib/src/Acton/Env.hs | 55 +- compiler/lib/src/Acton/SelectiveBack.hs | 648 ++++++++++++++++++++++++ 3 files changed, 681 insertions(+), 23 deletions(-) create mode 100644 compiler/lib/src/Acton/SelectiveBack.hs diff --git a/compiler/lib/package.yaml.in b/compiler/lib/package.yaml.in index fe2db1c84..536739982 100644 --- a/compiler/lib/package.yaml.in +++ b/compiler/lib/package.yaml.in @@ -93,6 +93,7 @@ library: - Acton.Reachability - Acton.ReachabilityPrinter - Acton.ReachabilityRows + - Acton.SelectiveBack - Acton.Solver - Acton.SourceProvider - Acton.Syntax diff --git a/compiler/lib/src/Acton/Env.hs b/compiler/lib/src/Acton/Env.hs index 9eb0d48f4..29bd45537 100644 --- a/compiler/lib/src/Acton/Env.hs +++ b/compiler/lib/src/Acton/Env.hs @@ -433,29 +433,38 @@ initEnv path True = return $ EnvF{ activeNames = [], context = [], qlevel = 0, envX = () } -initEnv path False = do (_,nmod) <- InterfaceFiles.readModuleIface (InterfaceFiles.interfacePath path (modName ["__builtin__"])) - let NModule _ envBuiltin builtinDocstring = nmod - envBuiltinPublic = publicTEnv envBuiltin - initialNames = [] - env0 = EnvF{ activeNames = [], - closedNames = initialNames, - hnames = hnamesFrom initialNames, - closedHNames = hnamesFrom initialNames, - sigLocs = M.empty, - closedSigLocs = M.empty, - defLocs = M.empty, - closedDefLocs = M.empty, - activeStateNames = [], - activeTypeVars = [], - imports = [], - qualifiers = [], - modules = Map.fromList [(mPrim, mkModuleInfo mPrim [] primEnv Nothing), (mBuiltin, mkModuleInfo mBuiltin [] envBuiltin builtinDocstring)], - thismod = Nothing, - context = [], - qlevel = 0, - envX = () } - env = importAll mBuiltin (mkModuleInfo mBuiltin [] envBuiltinPublic builtinDocstring) env0 - return env +initEnv path False = do (_,NModule _ envBuiltin builtinDocstring) <- + InterfaceFiles.readModuleIface + (InterfaceFiles.interfacePath path (modName ["__builtin__"])) + return (initEnvFromBuiltin envBuiltin builtinDocstring) + +-- | Construct the base environment from an already loaded builtin interface. +-- Deferred backs use this entry point so no memoized ModuleInfo from the front +-- scheduler leaks into their freshly constructed environment. +initEnvFromBuiltin :: TEnv -> Maybe String -> Env0 +initEnvFromBuiltin envBuiltin builtinDocstring = env + where envBuiltinPublic = publicTEnv envBuiltin + initialNames = [] + env0 = EnvF{ activeNames = [], + closedNames = initialNames, + hnames = hnamesFrom initialNames, + closedHNames = hnamesFrom initialNames, + sigLocs = M.empty, + closedSigLocs = M.empty, + defLocs = M.empty, + closedDefLocs = M.empty, + activeStateNames = [], + activeTypeVars = [], + imports = [], + qualifiers = [], + modules = Map.fromList [(mPrim, mkModuleInfo mPrim [] primEnv Nothing), (mBuiltin, mkModuleInfo mBuiltin [] envBuiltin builtinDocstring)], + thismod = Nothing, + context = [], + qlevel = 0, + envX = () } + env = importAll mBuiltin + (mkModuleInfo mBuiltin [] envBuiltinPublic builtinDocstring) + env0 withModulesFrom :: EnvF x -> EnvF x -> EnvF x env `withModulesFrom` env' = env{modules = modules env'} diff --git a/compiler/lib/src/Acton/SelectiveBack.hs b/compiler/lib/src/Acton/SelectiveBack.hs new file mode 100644 index 000000000..1fbf9330a --- /dev/null +++ b/compiler/lib/src/Acton/SelectiveBack.hs @@ -0,0 +1,648 @@ +-- SPDX-License-Identifier: BSD-3-Clause + +-- | Turn reachability into partial modules for deferred back passes. +-- +-- 'Reachability' closes the program roots over persisted +-- 'ReachabilityRows'. This module supplies its exact TYDB lookups, then uses +-- the resulting selection to reconstruct partial Acton modules from +-- 'InterfaceRows'. Selection and materialization each keep one read +-- transaction open per participating interface, and this module computes the +-- projected environments and hashes consumed by 'Compile'. +-- +-- Reachability analysis is deliberately separate from syntax loading: this +-- module does not inspect source syntax or run compiler passes. It is the IO +-- boundary between the pure selection and the ordinary deferred back-pass +-- pipeline. A missing row is a compiler/cache error, never a request to widen +-- the selection. +module Acton.SelectiveBack + ( InterfaceResolver + , Interfaces + , SelectedProgram + , Projection(..) + , SelectiveBackError(..) + , selectInterfaces + , selectedProgramSelection + , selectedProgramInterfaces + , materializeInterfaceProjections + , projectImports + , restrictEnvironmentPublicNames + , projectionModuleInfo + , loadInterfaceClosure + , bindInterfaces + , wholeModuleSeeds + , rootSeeds + , rootlessModules + , notImplementedModules + , interfaceSourceHash + , interfaceImplementationHash + , interfaceEnvironment + , materializeWholeModule + , selectedOpaqueHashes + , projectionUniverseHash + , projectionCodegenHash + ) where + +import Control.Exception (Exception, throwIO) +import Control.Monad (foldM, unless) +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.Binary as Binary +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as BL +import Data.List (sortOn) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import qualified Data.Set as Set + +import qualified Acton.Hashing as Hashing +import qualified Acton.Builtin as Builtin +import qualified Acton.InterfaceRows as Rows +import qualified Acton.Env as Env +import qualified Acton.NameInfo as I +import qualified Acton.Prim as Prim +import qualified Acton.QuickType as QuickType +import qualified Acton.Reachability as Reach +import Acton.ReachabilityRows +import qualified Acton.Syntax as A +import qualified InterfaceFiles + + +type InterfaceResolver = A.ModName -> IO (Maybe FilePath) + +data InterfaceFile = InterfaceFile + { interfacePath :: FilePath + , interfaceInfo :: InterfaceFiles.InterfaceSummary + } deriving (Eq, Show) + +newtype Interfaces = Interfaces + { interfaceMap :: Map.Map A.ModName InterfaceFile + } deriving (Eq, Show) + +data SelectedProgram = SelectedProgram + { selectedProgramSelection :: Reach.Selection + , selectedProgramInterfaces :: Interfaces + } deriving (Eq, Show) + +data Projection = Projection + { projectionModule :: A.Module + -- Compact inferred headers for materialized containers. Their member + -- environments are replaced with the selected members reconstructed from + -- syntax; every other inferred field remains authoritative. + , projectionHeaders :: I.TEnv + -- These headers have no materialized declaration body and are emitted as C + -- forward declarations only. + , projectionDeclarations :: I.TEnv + , projectionTypeEnv :: I.TEnv + , projectionTopCount :: Int + , projectionMemberCount :: Int + } deriving (Eq, Show) + +data SelectiveBackError + = MissingInterfaceModule A.ModName + | MissingPrimitiveName A.Name + | MissingSelectedNameHash FilePath A.Name + | InvalidSelectedHeader FilePath TopKey TopInfo + | MissingSelectedHeader FilePath TopKey + | MissingSelectedContainer FilePath TopKey + | MismatchedSelectedContainer FilePath TopKey + | MissingDeclarationHeader FilePath TopKey + | InvalidDeclarationHeader FilePath TopKey TopInfo + deriving (Eq, Show) + +instance Exception SelectiveBackError + + +-- Selection -------------------------------------------------------------------------------------------- + +selectInterfaces :: Interfaces + -> Set.Set A.ModName + -> [ReachEdge] + -> IO (Either Reach.SelectionError SelectedProgram) +selectInterfaces interfaces selectableModules seeds = do + result <- withInterfaceSessions interfaces (Map.keysSet $ interfaceMap interfaces) $ \sessions -> do + moduleSeeds <- fmap (concatMap reachEdges) $ mapM + (readModuleSummary sessions) (Set.toAscList selectableModules) + Reach.selectProgram (lookups sessions) (seeds ++ moduleSeeds) + return $ fmap + (\selection -> SelectedProgram + (classifyOpaqueDeclarations selection) interfaces) + result + where + readModuleSummary sessions mn = + fst <$> InterfaceFiles.readInterfaceSessionReachSummaries + (requiredSession sessions mn) mn + + lookups sessions = Reach.ReachLookup + { Reach.lookupTopRow = \key@(TopKey mn _) -> + if Set.member mn selectableModules || mn == Builtin.mBuiltin + then readOne sessions InterfaceFiles.readInterfaceSessionReachTopMaybe key + else return (Just $ OpaqueTop mempty) + , Reach.lookupMemberRow = \owner member -> + readOne sessions + (\session key -> InterfaceFiles.readInterfaceSessionReachMemberMaybe session key member) owner + , Reach.lookupShapeRow = readOne sessions InterfaceFiles.readInterfaceSessionReachShapeMaybe + , Reach.lookupSlotRow = \owner member -> + readOne sessions + (\session key -> InterfaceFiles.readInterfaceSessionReachSlotMaybe session key member) owner + , Reach.lookupSurfaceSlots = readRequired sessions + InterfaceFiles.readInterfaceSessionReachSlots + , Reach.lookupReflectableAttrs = + readOne sessions InterfaceFiles.readInterfaceSessionReachReflectionMaybe + } + + readOne :: Map.Map A.ModName InterfaceFiles.InterfaceReadSession + -> (InterfaceFiles.InterfaceReadSession -> TopKey -> IO (Maybe a)) + -> TopKey + -> IO (Maybe a) + readOne sessions readRow key@(TopKey mn _) = + case Map.lookup mn sessions of + Nothing -> return Nothing + Just session -> readRow session key + + readRequired sessions readRows key@(TopKey mn _) = + case Map.lookup mn sessions of + Nothing -> return [] + Just session -> readRows session key + + classifyOpaqueDeclarations selection = selection + { Reach.selectedDeclarations = localDeclarations + , Reach.selectedRows = Reach.selectedRows selection `Set.union` + Set.map Reach.OpaqueTopRow opaqueDeclarations + } + where + (opaqueDeclarations,localDeclarations) = Set.partition + (\(TopKey mn _) -> Set.notMember mn selectableModules) + (Reach.selectedDeclarations selection) + +-- Interface set ---------------------------------------------------------------------------------------- + +-- | Resolve the complete import closure once. Compile holds the output locks +-- for these modules until the deferred back passes finish, so ordinary LMDB +-- read transactions are sufficient; there is no second generation-validation +-- protocol here. +loadInterfaceClosure :: InterfaceResolver -> Set.Set A.ModName -> IO Interfaces +loadInterfaceClosure resolve initial = + Interfaces <$> go Map.empty (Set.toAscList $ Set.delete Prim.mPrim initial) + where + go loaded [] = return loaded + go loaded (mn:pending) + | mn == Prim.mPrim || Map.member mn loaded = go loaded pending + | otherwise = do + interface <- loadInterface resolve mn + let imports = InterfaceFiles.summaryClosureImports (interfaceInfo interface) + go (Map.insert mn interface loaded) (imports ++ pending) + +loadInterface :: InterfaceResolver -> A.ModName -> IO InterfaceFile +loadInterface resolve mn = do + path <- resolve mn >>= maybe (throwIO $ MissingInterfaceModule mn) return + info <- InterfaceFiles.readInterfaceSummaryMaybe path + case info of + Just current + | InterfaceFiles.summaryModuleName current == mn -> + return (InterfaceFile path current) + _ -> throwIO (MissingInterfaceModule mn) + +-- Public hashes and ordered source imports make the generated-code key change +-- whenever a lazy module lookup can observe a different public interface. +bindInterfaces :: B.ByteString -> Interfaces -> B.ByteString +bindInterfaces base = + SHA256.hash . BL.toStrict . Binary.encode . facts + where + facts interfaces = + ( "selective-interfaces-v1" :: String + , base + , [ ( semanticModName mn + , map semanticModName $ InterfaceFiles.summarySourceImports info + , InterfaceFiles.summaryPublicHash info + ) + | (mn,interface) <- Map.toAscList (interfaceMap interfaces) + , let info = interfaceInfo interface + ] + ) + +wholeModuleSeeds :: Interfaces -> Set.Set A.ModName -> IO [ReachEdge] +wholeModuleSeeds interfaces modules = + withInterfaceSessions interfaces selected $ \sessions -> + fmap (concatMap reachEdges) $ mapM (readOne sessions) (Set.toAscList selected) + where + selected = Set.delete Prim.mPrim modules + readOne sessions mn = snd <$> + InterfaceFiles.readInterfaceSessionReachSummaries + (requiredSession sessions mn) mn + +rootSeeds :: Interfaces -> [(A.ModName,A.Name)] -> IO [ReachEdge] +rootSeeds interfaces candidates = fmap concat $ mapM rootSeed candidates + where + rootSeed (mn,root) = do + interface <- requireInterface interfaces mn + return + [ Construct mn root + | root `elem` InterfaceFiles.summaryRoots (interfaceInfo interface) + ] + +rootlessModules :: Interfaces -> Set.Set A.ModName +rootlessModules = Map.keysSet . Map.filter noRoots . interfaceMap + where + noRoots = null . InterfaceFiles.summaryRoots . interfaceInfo + +notImplementedModules :: Interfaces -> Set.Set A.ModName +notImplementedModules = Map.keysSet . Map.filter hasNotImpl . interfaceMap + where + hasNotImpl = InterfaceFiles.summaryHasNotImpl . interfaceInfo + +interfaceSourceHash :: Interfaces -> A.ModName -> IO B.ByteString +interfaceSourceHash interfaces mn = + InterfaceFiles.summarySourceHash . interfaceInfo <$> requireInterface interfaces mn + +interfaceImplementationHash :: Interfaces -> A.ModName -> IO B.ByteString +interfaceImplementationHash interfaces mn = + InterfaceFiles.summaryImplementationHash . interfaceInfo <$> requireInterface interfaces mn + +-- | Rebuild the deferred environment from the same explicit interface set used +-- for selection. ModuleInfo performs its normal exact TYDB reads. +interfaceEnvironment :: Interfaces -> IO Env.Env0 +interfaceEnvironment interfaces = do + builtin <- requireInterface interfaces Builtin.mBuiltin + builtinDB <- InterfaceFiles.openInterfaceDB (interfacePath builtin) + (_, I.NModule _ builtinEnv builtinDoc) <- + InterfaceFiles.readInterfaceDBIface builtinDB + let base = Env.initEnvFromBuiltin builtinEnv builtinDoc + foldM install base (Map.toAscList $ interfaceMap interfaces) + where + install env (mn,interface) + | mn == Prim.mPrim || mn == Builtin.mBuiltin = return env + | otherwise = do + db <- InterfaceFiles.openInterfaceDB (interfacePath interface) + let info = interfaceInfo interface + moduleInfo = Env.mkTyFileModuleInfo mn + (InterfaceFiles.summarySourceImports info) + (InterfaceFiles.summaryDoc info) + db + return (Env.addModuleInfo mn moduleInfo env) + +materializeWholeModule :: Interfaces + -> A.ModName + -> IO (A.Module,B.ByteString) +materializeWholeModule interfaces mn = do + interface <- requireInterface interfaces mn + (_imports,_nmod,typed,_sourceMeta,_sourceHash,_publicHash,implementationHash, + _hashedImports,_depModules,_nameHashes,_roots,_tests,_doc) <- + InterfaceFiles.readFile (interfacePath interface) + unless (A.modname typed == mn) $ + throwIO (MissingInterfaceModule mn) + return (typed,implementationHash) + +requireInterface :: Interfaces -> A.ModName -> IO InterfaceFile +requireInterface interfaces mn = case Map.lookup mn (interfaceMap interfaces) of + Just interface -> return interface + Nothing -> throwIO (MissingInterfaceModule mn) + +withInterfaceSessions :: Interfaces + -> Set.Set A.ModName + -> (Map.Map A.ModName InterfaceFiles.InterfaceReadSession -> IO a) + -> IO a +withInterfaceSessions interfaces modules action = + open Map.empty (Set.toAscList $ Set.delete Prim.mPrim modules) + where + open sessions [] = action sessions + open sessions (mn:rest) = do + interface <- requireInterface interfaces mn + InterfaceFiles.withInterfaceReadSession (interfacePath interface) $ \session -> + open (Map.insert mn session sessions) rest + +requiredSession :: Map.Map A.ModName InterfaceFiles.InterfaceReadSession + -> A.ModName + -> InterfaceFiles.InterfaceReadSession +requiredSession sessions mn = case Map.lookup mn sessions of + Just session -> session + Nothing -> error ("Missing interface session for " ++ show mn) + +unionInterfaces :: Interfaces -> Interfaces -> Interfaces +unionInterfaces left right = + Interfaces (Map.union (interfaceMap left) (interfaceMap right)) + +-- Materialization -------------------------------------------------------------------------------------- + +materializeInterfaceProjections :: [A.ModName] + -> SelectedProgram + -> IO [Projection] +materializeInterfaceProjections modules program = + withInterfaceSessions interfaces (Set.fromList modules) $ \sessions -> + mapM (materialize sessions) modules + where + interfaces = selectedProgramInterfaces program + selection = selectedProgramSelection program + + materialize sessions mn = do + interface <- requireInterface interfaces mn + materializeProjection (interfacePath interface) + (requiredSession sessions mn) mn selection + +-- | Fingerprint opaque declarations, extending the interface set for +-- providers reached directly from external seeds. +selectedOpaqueHashes :: InterfaceResolver + -> SelectedProgram + -> IO (SelectedProgram,[(TopKey,B.ByteString)]) +selectedOpaqueHashes resolve program = do + opaqueInterfaces <- loadInterfaceClosure resolve missingModules + let interfaces = selectedProgramInterfaces program `unionInterfaces` opaqueInterfaces + capturedProgram = program{ selectedProgramInterfaces = interfaces } + let opaqueModules = Set.fromList + [ mn | TopKey mn _ <- opaqueTops, mn /= Prim.mPrim ] + hashes <- withInterfaceSessions interfaces opaqueModules $ \sessions -> + mapM (fingerprint interfaces sessions) opaqueTops + return (capturedProgram,hashes) + where + selection = selectedProgramSelection program + opaqueTops = Set.toAscList $ Reach.selectedOpaqueTops selection + captured = interfaceMap $ selectedProgramInterfaces program + missingModules = Set.fromList + [ mn + | TopKey mn _ <- opaqueTops + , mn /= Prim.mPrim + , Map.notMember mn captured + ] + + fingerprint interfaces sessions key@(TopKey mn name) + | mn == Prim.mPrim = case lookup name Prim.primEnv of + Nothing -> throwIO (MissingPrimitiveName name) + Just info -> case Map.lookup name $ Hashing.nameInfoHashes $ Map.singleton name info of + Nothing -> throwIO (MissingPrimitiveName name) + Just hash -> return (key,hash) + | otherwise = do + interface <- requireInterface interfaces mn + let session = requiredSession sessions mn + tyFile = interfacePath interface + row <- InterfaceFiles.readInterfaceSessionNameHashMaybe session name + info <- maybe (throwIO $ MissingSelectedNameHash tyFile name) return row + return (key,InterfaceFiles.nhPubHash info) + +materializeProjection :: FilePath + -> InterfaceFiles.InterfaceReadSession + -> A.ModName + -> Reach.Selection + -> IO Projection +materializeProjection tyFile session mn selection = do + nameHashes <- mapM readNameHash selectedNames + selectedModule <- InterfaceFiles.readInterfaceSessionSelection + session nameHashes (Set.fromList selectedNames) memberInterests + let typedModule = selectedModule + { A.imps = projectImports selection (A.imps selectedModule) } + headers <- catMaybes <$> mapM readSelectedHeader selectedKeys + declarations <- mapM readDeclaration declarationKeys + projectedEnv <- either throwIO return $ + mergeProjectionTEnv tyFile mn headers declarations + (projectionSyntaxEnv $ A.mbody typedModule) + return Projection + { projectionModule = typedModule + , projectionHeaders = headers + , projectionDeclarations = declarations + , projectionTypeEnv = projectedEnv + , projectionTopCount = length selectedNames + , projectionMemberCount = sum (map Set.size $ Map.elems memberInterests) + } + where + selectedKeys = + [ key + | key@(TopKey moduleName _) <- Set.toAscList (Reach.selectedTops selection) + , moduleName == mn + ] + selectedNames = [ name | TopKey _ name <- selectedKeys ] + declarationKeys = + [ key + | key@(TopKey moduleName _) <- Set.toAscList (Reach.selectedDeclarations selection) + , moduleName == mn + ] + memberInterests = Map.fromListWith Set.union + ( [ (ownerName, Set.singleton member) + | (TopKey moduleName ownerName, member) <- Set.toAscList (Reach.selectedMembers selection) + , moduleName == mn + ] ++ + [ (ownerName, Set.singleton $ Rows.StaticInit attr) + | (TopKey moduleName ownerName, attr) <- + Set.toAscList (Reach.selectedStaticInitializers selection) + , moduleName == mn + ] ++ + [ (ownerName, Set.singleton $ Rows.InstanceInit attr) + | (TopKey moduleName ownerName, attr) <- + Set.toAscList (Reach.selectedInstanceInitializers selection) + , moduleName == mn + ] + ) + + readNameHash name = do + row <- InterfaceFiles.readInterfaceSessionNameHashMaybe session name + maybe (throwIO $ MissingSelectedNameHash tyFile name) return row + + readSelectedHeader key@(TopKey _ name) = do + row <- InterfaceFiles.readInterfaceSessionReachTop session key + case row of + LocalTop header _ -> return $ fmap ((,) name) header + _ -> throwIO (InvalidSelectedHeader tyFile key row) + + readDeclaration key@(TopKey _ name) = do + row <- InterfaceFiles.readInterfaceSessionReachTop session key + case row of + LocalTop (Just info) _ -> return (name, info) + LocalTop Nothing _ -> throwIO (MissingDeclarationHeader tyFile key) + _ -> throwIO (InvalidDeclarationHeader tyFile key row) + +-- | Keep module imports, which name a qualifier or a wildcard, and project +-- explicit imports to the exact provider names retained by the global +-- selection. Wildcards are narrowed through 'restrictEnvironmentPublicNames' +-- so their ordinary importability rules remain unchanged. An empty explicit +-- import still carries the provider's module initialization dependency. +projectImports :: Reach.Selection -> [A.Import] -> [A.Import] +projectImports selection = map project + where + selected = Reach.selectedTops selection `Set.union` + Reach.selectedDeclarations selection `Set.union` + Reach.selectedOpaqueTops selection + + project importSpec = case importSpec of + A.FromImport loc mn items -> + A.FromImport loc mn (filter (retained mn) items) + _ -> importSpec + + retained mn (A.ImportItem name _) = + Set.member (TopKey mn name) selected + + +-- | Limit wildcard enumeration to names that the global selection has +-- already retained. The original ModuleInfo still decides whether each name +-- is importable, so extensions and other non-value entries keep their normal +-- wildcard behavior without loading unrelated public rows. +restrictEnvironmentPublicNames :: Reach.Selection -> Env.Env0 -> Env.Env0 +restrictEnvironmentPublicNames selection env = env + { Env.modules = Map.mapWithKey restrict (Env.modules env) } + where + selected = Reach.selectedTops selection `Set.union` + Reach.selectedDeclarations selection `Set.union` + Reach.selectedOpaqueTops selection + byModule = Map.fromListWith Set.union + [ (mn,Set.singleton name) + | TopKey mn name <- Set.toAscList selected + ] + restrict mn info = info + { Env.modulePublicNames = filter retained (Env.modulePublicNames info) } + where retained name = Set.member name $ Map.findWithDefault Set.empty mn byModule + +-- | Install the projected name environment while retaining the original +-- exact witness indexes. Type-directed lookup of converted witness methods +-- still needs those indexes; the projected names decide which witnesses are +-- available to the back passes. +projectionModuleInfo :: Env.Env0 -> Projection -> Env.ModuleInfo +projectionModuleInfo env projection = projectedInfo + { Env.moduleWitnessesByProto = Env.moduleWitnessesByProto original + , Env.moduleWitnessesByType = Env.moduleWitnessesByType original + } + where + typed = projectionModule projection + mn = A.modname typed + projected = projectionTypeEnv projection + moduleEnv = Env.defineClosed projected $ Env.setMod mn env + projectedInfo = Env.mkModuleInfo mn (A.importsOf typed) + (Env.unalias moduleEnv projected) (A.mdoc typed) + original = case Env.lookupModuleInfo mn env of + Just info -> info + Nothing -> error ("Missing module environment for selective projection " ++ show mn) + +mergeProjectionTEnv :: FilePath + -> A.ModName + -> I.TEnv + -> I.TEnv + -> I.TEnv + -> Either SelectiveBackError I.TEnv +mergeProjectionTEnv tyFile mn headers declarations syntaxEnv = do + mapM_ requireContainerHeader syntaxEnv + mapM_ requireSelectedContainer headers + merged <- mapM mergeBinding syntaxEnv + return (merged ++ declarations) + where + headerMap = Map.fromList headers + + requireContainerHeader (name,info) + | isContainerInfo info, + Map.notMember name headerMap = Left (MissingSelectedHeader tyFile $ TopKey mn name) + | otherwise = Right () + + requireSelectedContainer (name,_) = + case lookup name syntaxEnv of + Nothing -> Left (MissingSelectedContainer tyFile $ TopKey mn name) + Just _ -> Right () + + mergeBinding binding@(name,syntaxInfo) = + case Map.lookup name headerMap of + Nothing -> Right binding + Just headerInfo -> + case mergeContainerInfo headerInfo syntaxInfo of + Just info -> Right (name,info) + Nothing -> Left (MismatchedSelectedContainer tyFile $ TopKey mn name) + + isContainerInfo info = case info of + I.NClass{} -> True + I.NProto{} -> True + I.NAct{} -> True + I.NExt{} -> True + _ -> False + +mergeContainerInfo :: I.NameInfo -> I.NameInfo -> Maybe I.NameInfo +mergeContainerInfo header syntaxInfo = case (header,syntaxInfo) of + (I.NClass q bases [] doc, I.NClass _ _ members _) -> + Just (I.NClass q bases members doc) + (I.NProto q bases [] doc, I.NProto _ _ members _) -> + Just (I.NProto q bases members doc) + (I.NAct q pos kwd [] doc, I.NAct _ _ _ members _) -> + Just (I.NAct q pos kwd members doc) + (I.NExt q target bases [] opts doc, I.NExt _ _ _ members _ _) -> + Just (I.NExt q target bases members opts doc) + _ -> Nothing + +projectionSyntaxEnv :: A.Suite -> I.TEnv +projectionSyntaxEnv = QuickType.envOfTopSuite + + +-- Hashing ----------------------------------------------------------------------------------------------- + +-- | One semantic key for the whole selected universe. Consequently a change +-- in a selected consumer reruns every selected provider back pass, while an +-- edit confined to unmaterialized code is absent from the key. +projectionUniverseHash :: Reach.Selection + -> [Projection] + -> [(TopKey,B.ByteString)] + -> B.ByteString +projectionUniverseHash selection projections opaqueHashes = + SHA256.hash $ BL.toStrict $ Binary.encode + ( "selective-back-v4" :: String + , Hashing.codegenIdentity + , A.version + , selectionProjectionFacts selection + , sortOn fst + [ ( semanticModName $ A.modname typed + , Hashing.moduleProjectionHash typed (projectionTypeEnv projection) + ) + | projection <- projections + , let typed = projectionModule projection + ] + , [ (semanticModName mn,semanticName name,hash) + | (TopKey mn name,hash) <- sortOn fst opaqueHashes + ] + ) + +-- A canonical, constructor-tagged encoding of every closure fact that can +-- alter materialization or generated declarations. This deliberately avoids +-- Show: source locations and presentation changes are not semantic keys. +selectionProjectionFacts :: Reach.Selection + -> [(Int,A.ModName,A.Name,Int,Maybe A.Name)] +selectionProjectionFacts selection = + map (topFact 0) (Set.toAscList $ Reach.selectedDeclarations selection) ++ + map (topFact 1) (Set.toAscList $ Reach.selectedTops selection) ++ + map (topFact 2) (Set.toAscList $ Reach.selectedOpaqueTops selection) ++ + map (memberFact 3) (Set.toAscList $ Reach.selectedMembers selection) ++ + map (nameFact 4) (Set.toAscList $ Reach.selectedAttrs selection) ++ + map (nameFact 5) (Set.toAscList $ Reach.selectedStaticInitializers selection) ++ + map (nameFact 6) (Set.toAscList $ Reach.selectedInstanceInitializers selection) ++ + map (generatedFact 7) (Set.toAscList $ Reach.selectedGenerated selection) ++ + map (topFact 8) (Set.toAscList $ Reach.selectedConstructed selection) ++ + map (topFact 9) (Set.toAscList $ Reach.selectedInitialized selection) + where + topFact tag (TopKey moduleName name) = + (tag,semanticModName moduleName,semanticName name,0,Nothing) + + memberFact tag (key,member) = + let (memberTag,memberName) = memberKey member + (category,moduleName,owner,_,_) = topFact tag key + in (category,moduleName,owner,memberTag,memberName) + + nameFact tag (key,name) = + let (category,moduleName,owner,_,_) = topFact tag key + in (category,moduleName,owner,0,Just $ semanticName name) + + generatedFact tag (key,ref) = + let (refTag,refName) = memberRef ref + (category,moduleName,owner,_,_) = topFact tag key + in (category,moduleName,owner,refTag,refName) + + memberKey member = case member of + Rows.Method name -> (0,Just $ semanticName name) + Rows.Attr name -> (1,Just $ semanticName name) + Rows.StaticInit name -> (2,Just $ semanticName name) + Rows.InstanceInit name -> (3,Just $ semanticName name) + Rows.InitRest -> (4,Nothing) + + memberRef ref = case ref of + MethodRef name -> (0,Just $ semanticName name) + AttrRef name -> (1,Just $ semanticName name) + +semanticModName :: A.ModName -> A.ModName +semanticModName (A.ModName names) = A.ModName (map semanticName names) + +semanticName :: A.Name -> A.Name +semanticName (A.Name _ name) = A.name name +semanticName (A.Derived owner member) = + A.Derived (semanticName owner) (semanticName member) +semanticName name@A.Internal{} = name + +projectionCodegenHash :: B.ByteString -> A.ModName -> B.ByteString +projectionCodegenHash universe mn = + SHA256.hash $ BL.toStrict $ Binary.encode + ("selective-back-module-v4" :: String, universe, semanticModName mn) From 67a3d217f09459b82f8803e76e771a95aa7ca478 Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Tue, 18 Aug 2026 17:32:44 +0200 Subject: [PATCH 7/9] Schedule selective back passes Run back passes on the projected modules instead of the whole ones. Once every front pass has finished, partition the modules into those that must be rendered whole and those that can be projected, close the selection over the executable roots, and enqueue one back job per projected module with a codegen key derived from the whole selected universe. A rootless module that was directly requested stops after its interface unless a declared library boundary or a diagnostic output needs its back pass. Selective output for a provider lives in the provider's output tree but is keyed by the consumer's universe, so concurrent builds of different roots take a shared output lock. The language server compiles from a compile context and a changed-path set so it can reuse the plan cache. acton sig --reachability prints the closed project selection without running back jobs, or the cached rows of one module or name. --- .gitignore | 2 + compiler/acton/Main.hs | 149 +++- compiler/lib/package.yaml.in | 1 - compiler/lib/src/Acton/Compile.hs | 1379 ++++++++++++++++------------- compiler/lsp-server/Main.hs | 112 ++- 5 files changed, 961 insertions(+), 682 deletions(-) diff --git a/.gitignore b/.gitignore index 0b6bcf961..48436f0d0 100644 --- a/.gitignore +++ b/.gitignore @@ -16,6 +16,7 @@ **/zig-cache **/.acton.compile.lock **/.acton.lock +**/.acton.output.lock **/.build/ **/*.swp **/*.ty @@ -99,5 +100,6 @@ snapshots/output/** # tests organized as acton projects; ignore all but source test/**/out/** test/**/.acton.lock +test/**/.acton.output.lock compiler/acton/test/project/*/out compiler/acton/test/root/test diff --git a/compiler/acton/Main.hs b/compiler/acton/Main.hs index 8381f19f9..b1b3f4652 100644 --- a/compiler/acton/Main.hs +++ b/compiler/acton/Main.hs @@ -26,6 +26,8 @@ import Acton.Printer () import qualified Acton.Env import Acton.Env (simp, define, setMod) import qualified Acton.QuickType +import qualified Acton.ReachabilityPrinter as ReachabilityPrinter +import qualified Acton.ReachabilityRows as ReachRows import qualified Acton.Kinds import qualified Acton.Types import qualified Acton.Solver @@ -40,6 +42,7 @@ import qualified Acton.Builtin import qualified Acton.DocPrinter as DocP import qualified Acton.Diagnostics as Diag import qualified Acton.Fingerprint as Fingerprint +import qualified Acton.Hashing as Hashing import qualified Acton.SourceProvider as Source import Acton.Compile import Utils @@ -129,6 +132,9 @@ raiseOpenFileLimit = setResourceLimit ResourceOpenFiles lim{ softLimit = ResourceLimit target } main = do + -- Force the executable identity before compilation workers can query it. + -- Hashing memoizes the result for all later code-generation keys. + _ <- evaluate Hashing.codegenIdentity raiseOpenFileLimit hSetBuffering stdout LineBuffering arg <- C.parseCmdLine @@ -955,15 +961,20 @@ fetchCommand gopts = do putStrLn "Dependencies fetched" data SigTarget - = SigSourceTarget ProjCtx A.ModName (Maybe A.Name) FilePath + = SigProjectTarget + | SigSourceTarget ProjCtx A.ModName (Maybe A.Name) FilePath | SigTyTarget A.ModName (Maybe A.Name) FilePath sigCommand :: C.GlobalOptions -> C.SigOptions -> IO () sigCommand gopts sigOpts = do + let projectTarget = maybe True (== ".") (C.sigTarget sigOpts) + when (projectTarget && not (C.sigReachability sigOpts)) $ + printErrorAndExit "Signature target required; use --reachability for the project" let opts0 = (C.sigCompile sigOpts) { C.skip_build = True , C.only_build = False , C.sigs = False + , C.no_dbp = not projectTarget } queryGopts = if C.verbose gopts then gopts else gopts { C.quiet = True } paths0 <- loadProjectPaths opts0 @@ -974,39 +985,66 @@ sigCommand gopts sigOpts = do sysAbs <- normalizePathSafe (sysPath paths) withProjectLockNotice queryGopts rootProj $ do fetchDependencies queryGopts paths depOverrides - projMap <- discoverProjects queryGopts sysAbs rootProj depOverrides - target <- resolveSigTarget opts paths rootProj projMap (C.sigTarget sigOpts) - tyFile <- case target of - SigSourceTarget ctx mn _ srcPath -> - compileSigTarget gopts queryGopts opts paths rootProj sysAbs depOverrides ctx mn srcPath - SigTyTarget _ _ tyPath -> - return tyPath - case target of - SigSourceTarget _ mn mName _ -> printSigInterface paths mn mName tyFile - SigTyTarget mn mName _ -> printSigInterface paths mn mName tyFile + buildStamp <- readBuildSpecStamp (projPath paths) + let compileCtx = CompileContext + { ccOpts = opts + , ccDepOverrides = depOverrides + , ccPathsRoot = paths + , ccRootProj = rootProj + , ccSysAbs = sysAbs + , ccBuildStamp = buildStamp + } + lockPaths <- compileOutputLockPaths queryGopts compileCtx + withCompileOutputLockPaths lockPaths $ do + target <- case C.sigTarget sigOpts of + Nothing -> return SigProjectTarget + Just "." -> return SigProjectTarget + Just rawTarget -> do + projMap <- discoverProjects queryGopts sysAbs rootProj depOverrides + resolveSigTarget opts paths rootProj projMap rawTarget + case target of + SigProjectTarget -> + printProjectReachability gopts queryGopts compileCtx paths + SigSourceTarget ctx mn mName srcPath -> do + tyFile <- compileSigTarget gopts queryGopts compileCtx ctx mn srcPath + printSigResult (C.sigReachability sigOpts) paths mn mName tyFile + SigTyTarget mn mName tyFile -> + printSigResult (C.sigReachability sigOpts) paths mn mName tyFile + +printProjectReachability :: C.GlobalOptions + -> C.GlobalOptions + -> CompileContext + -> Paths + -> IO () +printProjectReachability gopts queryGopts cctx paths = do + let sp = Source.diskSourceProvider + srcFiles <- projectSourceFiles paths + plan <- prepareCompilePlanFromContext sp queryGopts cctx srcFiles True Nothing + let cctx' = cpContext plan + opts' = ccOpts cctx' + callbacks = defaultCompileCallbacks + { ccOnDiagnostics = \_ optsT diags -> printDiagnostics gopts optsT diags + , ccOnInfo = \msg -> when (C.verbose gopts) $ putStrLn msg + , ccOnBackJob = \_ -> return () + , ccOnReachability = \whole selection -> + putStrLn (ReachabilityPrinter.prettySelection whole selection) + } + compileRes <- compileTasks sp queryGopts opts' (ccPathsRoot cctx') (ccRootProj cctx') + (cpRootTaskKeys plan) (cpRequestedTasks plan) + (cpNeededTasks plan) (cpDbpBlocked plan) callbacks + case compileRes of + Left err -> printErrorAndExit (compileFailureMessage err) + Right (_, hadErrors) -> when hadErrors System.Exit.exitFailure compileSigTarget :: C.GlobalOptions -> C.GlobalOptions - -> C.CompileOptions - -> Paths - -> FilePath - -> FilePath - -> [(String, FilePath)] + -> CompileContext -> ProjCtx -> A.ModName -> FilePath -> IO FilePath -compileSigTarget gopts queryGopts opts paths rootProj sysAbs depOverrides targetCtx mn srcPath = do - buildStamp <- readBuildSpecStamp (projPath paths) +compileSigTarget gopts queryGopts cctx targetCtx mn srcPath = do let sp = Source.diskSourceProvider - cctx = CompileContext - { ccOpts = opts - , ccDepOverrides = depOverrides - , ccPathsRoot = paths - , ccRootProj = rootProj - , ccSysAbs = sysAbs - , ccBuildStamp = buildStamp - } plan <- prepareCompilePlanFromContext sp queryGopts cctx [srcPath] False Nothing let cctx' = cpContext plan opts' = ccOpts cctx' @@ -1015,7 +1053,9 @@ compileSigTarget gopts queryGopts opts paths rootProj sysAbs depOverrides target , ccOnInfo = \msg -> when (C.verbose gopts) $ putStrLn msg , ccOnBackJob = \_ -> return () } - compileRes <- compileTasks sp queryGopts opts' (ccPathsRoot cctx') (ccRootProj cctx') (cpNeededTasks plan) (cpDbpBlocked plan) callbacks + compileRes <- compileTasks sp queryGopts opts' (ccPathsRoot cctx') (ccRootProj cctx') + (cpRootTaskKeys plan) (cpRequestedTasks plan) + (cpNeededTasks plan) (cpDbpBlocked plan) callbacks case compileRes of Left err -> printErrorAndExit (compileFailureMessage err) Right (_, hadErrors) -> when hadErrors System.Exit.exitFailure @@ -1143,6 +1183,28 @@ printSigInterface paths mn mName tyFile = do _ -> putStrLn (Acton.Types.prettySigs envForPrint mn (map dropPrefix imps) (Acton.Names.nmap dropPrefix selected)) +printSigResult :: Bool -> Paths -> A.ModName -> Maybe A.Name -> FilePath -> IO () +printSigResult showReachability paths mn mName tyFile + | showReachability = printSigReachability mn mName tyFile + | otherwise = printSigInterface paths mn mName tyFile + +printSigReachability :: A.ModName -> Maybe A.Name -> FilePath -> IO () +printSigReachability mn mName tyFile = do + exists <- InterfaceFiles.interfaceExists tyFile + unless exists $ + printErrorAndExit ("Type interface not found for " ++ modNameToString mn) + rowsRes <- try (InterfaceFiles.readReachabilityRows tyFile mn mName) + :: IO (Either SomeException ReachRows.ReachabilityRows) + case rowsRes of + Left err -> + printErrorAndExit + ("Could not read reachability for " ++ modNameToString mn ++ ": " ++ show err) + Right rows -> case mName of + Just name | M.null (ReachRows.reachTopRows rows) -> + printErrorAndExit + ("Name not found: " ++ modNameToString mn ++ "." ++ nameToString name) + _ -> putStrLn (ReachabilityPrinter.prettyRows mn mName rows) + -- Show dependency tree with overrides applied from root pins pkgShow :: C.GlobalOptions -> IO () pkgShow gopts = do @@ -1398,8 +1460,6 @@ compileFilesChanged sp gopts opts srcFiles allowPrune mChangedPaths mSched mProg cleanupProgress let runCompile = do sp' <- overlayChangedPaths sp mChangedPaths - planRes <- try $ - prepareCompilePlan sp' gopts sched opts srcFiles allowPrune mChangedPaths let reportPlanError (ProjectError msg) = do if C.watch opts then logLine msg @@ -1423,7 +1483,7 @@ compileFilesChanged sp gopts opts srcFiles allowPrune mChangedPaths mSched mProg reportCompileErrors = finalizeCompile $ unless watchMode System.Exit.exitFailure - compileRes <- runCompilePlan sp gopts plan sched gen (cchHooks cliHooks) + compileRes <- runCompilePlan sp' gopts plan sched gen (cchHooks cliHooks) case compileRes of Left err -> reportCompileError (compileFailureMessage err) @@ -1442,7 +1502,18 @@ compileFilesChanged sp gopts opts srcFiles allowPrune mChangedPaths mSched mProg clearProgress whenCurrentGen sched gen (runCliPostCompile cliHooks gopts plan env) return False - either reportPlanError runPlan planRes + planRun <- try $ do + ctx <- prepareCompileContext opts srcFiles + specChanged <- checkBuildSpecChange sched (ccBuildStamp ctx) + when specChanged $ + fetchDependencies gopts (ccPathsRoot ctx) (ccDepOverrides ctx) + lockPaths <- compileOutputLockPaths gopts ctx + withCompileOutputLockPaths lockPaths $ do + let changed = if specChanged then Nothing else mChangedPaths + plan <- prepareCompilePlanFromContext + sp' gopts ctx srcFiles allowPrune changed + runPlan plan + either reportPlanError return planRun runCompile `finally` cleanupProgress overlayChangedPaths :: Source.SourceProvider -> Maybe [FilePath] -> IO Source.SourceProvider @@ -2288,9 +2359,15 @@ pubHash, and a downstream module only needs front passes when a pubHash changes. Implementation hashing: each top-level name gets an implHash computed from its source hash plus the impl hashes of its dependencies. The moduleImplHash is the -hash of all per-name impl hashes. We embed moduleImplHash into generated .c/.h -files so we can skip back passes when codegen is already up to date, and we use -it (with impl deps) to drive the test cache. +hash of all per-name impl hashes and, together with impl dependencies, drives +back-pass refreshes and the test cache. + +Code-generation hashing: generated .c/.h files carry the exact hash of the back +passes that produced them. A whole-module back pass combines moduleImplHash +with the source bytes, compiler identity, and line-directive mode. A selective +back pass instead hashes the selected tops, members, ABI declarations, and their +captured interface universe, so unselected implementation is absent from the +key. A mismatch reruns back passes without rerunning front passes. Terminology - ParseTask: a source-backed module whose imports are known but whose full AST @@ -2342,8 +2419,8 @@ High-level Steps - Otherwise, compare each used impl dependency hash from the dependent’s .tydb header with the provider’s current impl hash. If any differ → refresh impl hashes and run back passes. - - Otherwise, if generated .c/.h hashes do not match moduleImplHash → run - back passes. + - Otherwise, if generated .c/.h hashes do not match the expected codegen + hash → run back passes. - Otherwise → module is fresh (no work). - We maintain a pubMap while walking modules in topological order. After a module compiles, we insert its freshly computed public hash; when a diff --git a/compiler/lib/package.yaml.in b/compiler/lib/package.yaml.in index 536739982..8fff73492 100644 --- a/compiler/lib/package.yaml.in +++ b/compiler/lib/package.yaml.in @@ -119,7 +119,6 @@ tests: - -rtsopts - -with-rtsopts=-N - -Wno-x-partial - executables: compiler-bench: main: CompilerBench.hs diff --git a/compiler/lib/src/Acton/Compile.hs b/compiler/lib/src/Acton/Compile.hs index 98327838b..9ae520145 100644 --- a/compiler/lib/src/Acton/Compile.hs +++ b/compiler/lib/src/Acton/Compile.hs @@ -37,11 +37,11 @@ Call flow: builds a CompilePlan for the requested subgraph. Parsing is performed through parseActSource/parseActSnapshot/parseActFile so SourceProvider overlays can supply unsaved buffers. - 2) runCompilePlan drives compileTasks. As each module finishes its front - passes, the CompileHooks callbacks (for example chOnFrontResult) - enqueue a BackJob into the scheduler's - BackQueue, so back passes begin as soon as they are ready and can overlap - remaining front passes. + 2) runCompilePlan drives compileTasks. Whole-module BackJobs can enter the + scheduler's BackQueue as soon as their front passes finish and overlap + remaining front work. Selective jobs retain only reloadable metadata; + after the required fronts have committed their interfaces, one global + reachability closure prepares the deferred batch. 3) Callers either wait for backQueueWait (CLI builds) or let back jobs run in the background. CLI builds wait before invoking Zig. 4) runBackJobs/runBackPasses can be used for standalone back-pass execution @@ -74,8 +74,8 @@ State and orchestration: (LSP uses debounceMicros, acton watch uses 0). Back jobs and front-output writes are filtered by generation; front-pass diagnostics should be gated by the caller if needed. - - CLI builds share the same pipeline and enqueue back jobs as soon as front - passes finish, overlapping work without needing a watch event source. + - CLI builds share the same pipeline. Whole back jobs can overlap front work; + selective jobs are prepared after the required front passes finish. TODO: - Make generation invalidation more precise so unrelated in-flight modules @@ -128,6 +128,8 @@ module Acton.Compile , CompileHooks(..) , defaultCompileHooks , runCompilePlan + , compileOutputLockPaths + , withCompileOutputLockPaths , CompileFailure(..) , compileFailureMessage , BackPassFailure(..) @@ -214,6 +216,9 @@ import qualified Acton.Env import qualified Acton.TypeEnv import Acton.Env (simp, define, setMod) import qualified Acton.Hashing as Hashing +import qualified Acton.InterfaceRows as InterfaceRows +import qualified Acton.Reachability as Reachability +import qualified Acton.SelectiveBack as SelectiveBack import qualified Acton.Names as Names import qualified Acton.Kinds import qualified Acton.Types @@ -244,7 +249,6 @@ import Control.Concurrent.STM (TChan, TVar, atomically, check, modifyTVar', newT import Control.DeepSeq (rnf) import Control.Exception (Exception, IOException, SomeAsyncException, SomeException, bracketOnError, catch, displayException, evaluate, finally, fromException, mask_, throwIO, try) import Control.Monad -import Data.Binary (encode) import Data.Bits (shiftL, shiftR, (.|.)) import Data.Char (isAlpha, isDigit, isHexDigit, isSpace) import Data.Either (partitionEithers) @@ -284,19 +288,14 @@ import Text.Printf import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Base16 as Base16 import qualified Crypto.Hash.SHA256 as SHA256 newtype ProjectError = ProjectError String deriving (Show) -instance Exception ProjectError - -newtype DbpSelectionError = DbpSelectionError String deriving (Show) - -instance Exception DbpSelectionError where - displayException (DbpSelectionError msg) = msg +instance Exception ProjectError where + displayException (ProjectError msg) = msg newtype FrontOutputError = FrontOutputError String deriving (Show) @@ -444,6 +443,7 @@ data CompileCallbacks = CompileCallbacks , ccShouldWriteFrontOutput :: IO Bool , ccOnBackJob :: BackJob -> IO () , ccOnBackSkipped :: TaskKey -> IO () + , ccOnReachability :: Data.Set.Set A.ModName -> Reachability.Selection -> IO () , ccOnInfo :: String -> IO () } @@ -465,6 +465,7 @@ defaultCompileCallbacks = CompileCallbacks , ccShouldWriteFrontOutput = return True , ccOnBackJob = \_ -> return () , ccOnBackSkipped = \_ -> return () + , ccOnReachability = \_ _ -> return () , ccOnInfo = \_ -> return () } @@ -514,8 +515,8 @@ checkBuildSpecChange sched stamp = -- | Create a concurrent back-pass queue gated by a generation counter. -- Each job is tagged with a generation id; stale jobs are skipped. -newBackQueue :: IORef Int -> C.GlobalOptions -> Int -> IO BackQueue -newBackQueue genRef gopts maxPar = do +newBackQueue :: IORef Int -> MVar () -> C.GlobalOptions -> Int -> IO BackQueue +newBackQueue genRef generationLock gopts maxPar = do queue <- newTChanIO counts <- newTVarIO M.empty failures <- newTVarIO M.empty @@ -540,47 +541,53 @@ newBackQueue genRef gopts maxPar = do writeTChan queue (gen, job, callbacks) return True waitDone gen = atomically $ do + pending <- readTVar counts + check (M.findWithDefault 0 gen pending == 0) failuresNow <- readTVar failures - case M.lookup gen failuresNow of - Just failure -> do - modifyTVar' failures (M.delete gen) - return (Just failure) - Nothing -> do - pending <- readTVar counts - let n = M.findWithDefault 0 gen pending - check (n == 0) - return Nothing + modifyTVar' failures (M.delete gen) + return (M.lookup gen failuresNow) worker = forever $ do (gen, job, callbacks) <- atomically $ readTChan queue + process gen job callbacks + `finally` atomically (modifyTVar' counts $ decPending gen) + + process gen job callbacks = do current <- readIORef genRef - if current /= gen - then atomically $ modifyTVar' counts (decPending gen) - else do - failed <- atomically $ do - failuresNow <- readTVar failures - return (M.member gen failuresNow) - if failed - then atomically $ modifyTVar' counts (decPending gen) - else do - let shouldWrite = do - currentWrite <- readIORef genRef - return (currentWrite == gen) - bjcOnStart callbacks job - res <- (try $ - runBackPassesWithProgress - gopts (bjOpts job) (bjPaths job) (bjInput job) - shouldWrite (bjcOnProgress callbacks job)) - :: IO (Either SomeException (Maybe TimeSpec, Maybe BackTiming)) - currentDone <- readIORef genRef - when (currentDone == gen) $ - case res of - Left err -> do - let key = TaskKey (projPath (bjPaths job)) (A.modname (biTypedMod (bjInput job))) - failure = BackPassFailure key (displayException err) - atomically $ modifyTVar' failures (recordFailure gen failure) - bjcOnDone callbacks job (BackJobFailed failure) - Right (t, bt) -> bjcOnDone callbacks job (BackJobOk t bt) - atomically $ modifyTVar' counts (decPending gen) + when (current == gen) $ do + failed <- M.member gen <$> atomically (readTVar failures) + unless failed $ do + let commitWrite action = withMVar generationLock $ \_ -> do + currentWrite <- readIORef genRef + if currentWrite == gen + then action >> return True + else return False + res <- (try $ do + bjcOnStart callbacks job + result <- runBackPasses + gopts (bjOpts job) (bjPaths job) (bjInput job) + commitWrite (bjcOnProgress callbacks job) + return result) + :: IO (Either SomeException (Maybe TimeSpec, Maybe BackTiming)) + currentDone <- readIORef genRef + when (currentDone == gen) $ publish gen job callbacks res + + publish gen job callbacks res = do + result <- case res of + Left err -> do + let failure = jobFailure job err + atomically $ modifyTVar' failures (recordFailure gen failure) + return (BackJobFailed failure) + Right (t,bt) -> return (BackJobOk t bt) + done <- try (bjcOnDone callbacks job result) :: IO (Either SomeException ()) + case done of + Left err -> atomically $ modifyTVar' failures + (recordFailure gen $ jobFailure job err) + Right () -> return () + + jobFailure job err = BackPassFailure key (displayException err) + where key = TaskKey + (projPath $ bjPaths job) + (A.modname $ biTypedMod $ bjInput job) let workers = max 1 maxPar replicateM_ workers (forkIO worker) return BackQueue @@ -590,6 +597,7 @@ newBackQueue genRef gopts maxPar = do data CompileScheduler = CompileScheduler { csGenRef :: IORef Int + , csGenerationLock :: MVar () , csAsyncRef :: MVar (Maybe (Async ())) , csBackQueue :: BackQueue , csBuildStampRef :: IORef (Maybe BuildSpecStamp) @@ -599,11 +607,13 @@ data CompileScheduler = CompileScheduler newCompileScheduler :: C.GlobalOptions -> Int -> IO CompileScheduler newCompileScheduler gopts maxPar = do genRef <- newIORef 0 + generationLock <- newMVar () asyncRef <- newMVar Nothing - backQueue <- newBackQueue genRef gopts maxPar + backQueue <- newBackQueue genRef generationLock gopts maxPar buildStampRef <- newIORef Nothing return CompileScheduler { csGenRef = genRef + , csGenerationLock = generationLock , csAsyncRef = asyncRef , csBackQueue = backQueue , csBuildStampRef = buildStampRef @@ -613,7 +623,8 @@ newCompileScheduler gopts maxPar = do -- Returns the generation id associated with this run. startCompile :: CompileScheduler -> Int -> (Int -> IO ()) -> IO Int startCompile sched delay run = do - gen <- atomicModifyIORef' (csGenRef sched) $ \g -> let g' = g + 1 in (g', g') + gen <- withMVar (csGenerationLock sched) $ \_ -> + atomicModifyIORef' (csGenRef sched) $ \g -> let g' = g + 1 in (g', g') modifyMVar_ (csAsyncRef sched) $ \m -> do forM_ m $ \old -> do -- The canceled action drains front-output jobs in its finalizer; wait so @@ -688,6 +699,8 @@ data CompilePlan = CompilePlan , cpNeededTasks :: [GlobalTask] , cpDbpBlocked :: Data.Set.Set TaskKey , cpRootTasks :: [CompileTask] + , cpRootTaskKeys :: Data.Set.Set TaskKey + , cpRequestedTasks :: Data.Set.Set TaskKey , cpRootPins :: M.Map String BuildSpec.PkgDep , cpIncremental :: Bool , cpAllowPrune :: Bool @@ -734,11 +747,17 @@ prepareCompilePlanFromContext sp gopts ctx srcFiles allowPrune mChangedPaths = d (globalTasks, _) <- buildGlobalTasks sp gopts opts' projMap (if incremental || allowPrune || hasBuildLibraries then Nothing else Just srcFiles) let dbpBlocked = libraryBoundaryTasks projMap globalTasks + requestedKeys <- taskKeysForFiles pathsRoot rootProj globalTasks srcFiles neededTasks0 <- case mChangedPaths of Nothing -> selectNeededTasks pathsRoot rootProj globalTasks srcFiles Just changed -> selectAffectedTasks rootProj opts' globalTasks dbpBlocked changed let neededTasks = expandBuildLibraryTasks projMap globalTasks neededTasks0 rootTasks = [ gtTask t | t <- neededTasks0, tkProj (gtKey t) == rootProj ] + rootTaskKeys = Data.Set.fromList + [ gtKey t | t <- neededTasks0, tkProj (gtKey t) == rootProj ] + requestedTasks + | allowPrune = Data.Set.empty + | otherwise = Data.Set.fromList requestedKeys rootPins = maybe M.empty (BuildSpec.dependencies . projBuildSpec) (M.lookup rootProj projMap) return CompilePlan { cpContext = ctx @@ -747,6 +766,8 @@ prepareCompilePlanFromContext sp gopts ctx srcFiles allowPrune mChangedPaths = d , cpNeededTasks = neededTasks , cpDbpBlocked = dbpBlocked , cpRootTasks = rootTasks + , cpRootTaskKeys = rootTaskKeys + , cpRequestedTasks = requestedTasks , cpRootPins = rootPins , cpIncremental = incremental , cpAllowPrune = allowPrune' @@ -837,7 +858,34 @@ runCompilePlan sp gopts plan sched gen hooks0 = withAnalytics $ \ana -> do , ccOnBackSkipped = chOnBackSkipped hooks , ccOnInfo = chOnInfo hooks } - compileTasks sp gopts opts' pathsRoot rootProj (cpNeededTasks plan) (cpDbpBlocked plan) callbacks + compileTasks sp gopts opts' pathsRoot rootProj + (cpRootTaskKeys plan) (cpRequestedTasks plan) + (cpNeededTasks plan) (cpDbpBlocked plan) callbacks + +-- | Selective C/H is keyed by one consumer universe but lives in the provider +-- project's output tree. Hold every participating output lock, in canonical +-- order, through back passes and native consumption so concurrent root builds +-- cannot overwrite a shared provider projection underneath each other. +-- Discover the output locks before reading any shared interface state. +-- Dependency fetches happen before this point; project discovery itself is +-- read-only with respect to compiler outputs. +compileOutputLockPaths :: C.GlobalOptions -> CompileContext -> IO [FilePath] +compileOutputLockPaths gopts ctx + | isTmp paths = return [lockPath root] + | otherwise = do + projects <- discoverProjects gopts (ccSysAbs ctx) root (ccDepOverrides ctx) + return [ lockPath (projRoot project) | project <- M.elems projects ] + where + paths = ccPathsRoot ctx + root = ccRootProj ctx + lockPath projectRoot = joinPath [projectRoot, ".acton.output.lock"] + +withCompileOutputLockPaths :: [FilePath] -> IO a -> IO a +withCompileOutputLockPaths = lockAll . Data.List.sort . nub + where + lockAll [] action = action + lockAll (path:paths) action = + withFileLock path Exclusive $ \_ -> lockAll paths action -- | Tap the generic progress hooks to feed the analytics sampler. Each pass -- already reports through these callbacks, so a single wrapper covers parse, @@ -1212,14 +1260,30 @@ readSourceFileMeta path = do fileStatusMTimeNs st = floor (toRational (modificationTimeHiRes st) * 1000000000) fileStatusCTimeNs st = floor (toRational (statusChangeTimeHiRes st) * 1000000000) +-- | Read the source paired with a cached interface, rejecting a concurrent +-- edit instead of generating output from source text that does not match the +-- interface and codegen hash selected for this compile generation. +readMatchingSource :: Source.SourceProvider + -> A.ModName + -> B.ByteString + -> FilePath + -> IO Source.SourceSnapshot +readMatchingSource sp mn expected path = do + snap <- Source.readSource sp path + unless (SHA256.hash (Source.ssBytes snap) == expected) $ + throwIO $ ProjectError $ + "Source changed while preparing back passes for " ++ modNameToString mn + return snap + -- Compilation tasks, chasing imported modules, compilation and building executables ----------------- data BackInput = BackInput { biTypeEnv :: Acton.Env.Env0 , biTypedMod :: A.Module - , biSrc :: String - , biImplHash :: B.ByteString + , biDeclarations :: [A.Name] + , biSrc :: Maybe String + , biCodegenHash :: B.ByteString } data BackJob = BackJob @@ -1234,8 +1298,6 @@ data DeferredBackJob = DeferredBackJob { dbjPaths :: Paths , dbjOpts :: C.CompileOptions , dbjMod :: A.ModName - , dbjImplHash :: B.ByteString - , dbjNameCount :: Int } data FrontOutputJob = FrontOutputJob @@ -1252,7 +1314,6 @@ data FrontResult = FrontResult , frPubHash :: B.ByteString , frImplHash :: B.ByteString , frNameHashes :: [InterfaceFiles.NameHashInfo] - , frInterestDeps :: Data.Set.Set (A.ModName, A.Name) , frFrontTime :: Maybe TimeSpec , frFrontTiming :: Maybe FrontTiming , frInferredSigs :: [InferredSignature] @@ -1265,8 +1326,6 @@ frontResultModuleInfo :: A.ModName -> FrontResult -> Acton.Env.ModuleInfo frontResultModuleInfo mn fr = fromMaybe (Acton.Env.mkModuleInfo mn (frImps fr) (frIfaceTE fr) (frDoc fr)) (frModuleInfo fr) -type InterestMap = M.Map A.ModName (Data.Set.Set A.Name) - docNameCountThreshold :: Int docNameCountThreshold = 10000 @@ -1274,16 +1333,20 @@ shouldGenerateDocOutput :: C.CompileOptions -> Bool -> Int -> Bool shouldGenerateDocOutput opts tmp nameCount = not (C.skip_build opts) && not tmp && nameCount <= docNameCountThreshold -dbpDeferredBackJob :: Bool - -> Bool - -> C.CompileOptions - -> Paths - -> A.ModName - -> B.ByteString - -> Int - -> Maybe DeferredBackJob -dbpDeferredBackJob blocked hasNotImpl opts paths mn moduleImplHash nameCount +shouldRunBackPass :: Bool -> Bool -> C.CompileOptions -> [A.Name] -> Bool +shouldRunBackPass dbpBlocked requested opts roots = + dbpBlocked || altOutput opts || not requested || not (null roots) + +selectiveDeferredBackJob :: Bool + -> Bool + -> C.CompileOptions + -> Paths + -> A.ModName + -> Maybe DeferredBackJob +selectiveDeferredBackJob blocked hasNotImpl opts paths mn | C.no_dbp opts = Nothing + -- Persistence restores classes by stored id, outside static reachability. + | C.db opts = Nothing | C.only_build opts = Nothing | altOutput opts = Nothing | mn == A.modName ["__builtin__"] = Nothing @@ -1297,32 +1360,8 @@ dbpDeferredBackJob blocked hasNotImpl opts paths mn moduleImplHash nameCount { dbjPaths = paths , dbjOpts = opts , dbjMod = mn - , dbjImplHash = moduleImplHash - , dbjNameCount = nameCount } -interestDepsFromNameHashes :: [InterfaceFiles.NameHashInfo] -> Data.Set.Set (A.ModName, A.Name) -interestDepsFromNameHashes nameHashes = - Data.Set.fromList - [ target - | nh <- nameHashes - , (qn, _) <- InterfaceFiles.nhPubDeps nh ++ InterfaceFiles.nhImplDeps nh - , Just target <- [interestTarget qn] - ] - where - interestTarget qn = - case qn of - A.GName m n -> Just (m, n) - A.QName m n -> Just (m, n) - A.NoQ{} -> Nothing - -addInterestDeps :: Data.Set.Set (A.ModName, A.Name) -> InterestMap -> InterestMap -addInterestDeps deps im = - foldl' - (\acc (mn, n) -> M.insertWith Data.Set.union mn (Data.Set.singleton n) acc) - im - (Data.Set.toList deps) - startFrontOutputJob :: (TaskKey -> FrontOutputKind -> IO ()) -> (TaskKey -> FrontOutputKind -> Maybe TimeSpec -> IO ()) -> IO Bool @@ -1639,40 +1678,43 @@ buildGlobalTasks sp gopts opts projMap mSeeds = do -- | Select the subgraph needed for a given build request. -- Maps file paths to TaskKeys, adds __builtin__, and computes the reachable -- dependency closure. +taskKeysForFiles :: Paths -> FilePath -> [GlobalTask] -> [FilePath] -> IO [TaskKey] +taskKeysForFiles pathsRoot rootProj globalTasks srcFiles = do + requested <- catMaybes <$> mapM lookupTaskKey srcFiles + let wantedNames = map takeFileName srcFiles + return $ if null requested + then [ gtKey task + | task <- globalTasks + , takeFileName (srcFile (gtPaths task) (tkMod $ gtKey task)) `elem` wantedNames + ] + else requested + where + lookupTaskKey file = do + absolute <- canonicalizePath file + case listToMaybe + [ gtKey task + | task <- globalTasks + , srcFile (gtPaths task) (tkMod $ gtKey task) == absolute + ] of + Just key -> return (Just key) + Nothing -> do + mn <- moduleNameFromFile (srcDir pathsRoot) (projName pathsRoot) absolute + return $ listToMaybe + [ gtKey task + | task <- globalTasks + , tkProj (gtKey task) == rootProj + , tkMod (gtKey task) == mn + ] + selectNeededTasks :: Paths -> FilePath -> [GlobalTask] -> [FilePath] -> IO [GlobalTask] selectNeededTasks pathsRoot rootProj globalTasks srcFiles = do - requestedKeys <- catMaybes <$> mapM (lookupTaskKey globalTasks) srcFiles - let wantedNames = map takeFileName srcFiles - requestedKeys' = if null requestedKeys - then [ gtKey t - | t <- globalTasks - , takeFileName (srcFile (gtPaths t) (tkMod (gtKey t))) `elem` wantedNames - ] - else requestedKeys - builtinKeys = [ gtKey t | t <- globalTasks, tkMod (gtKey t) == A.modName ["__builtin__"] ] - startKeys = if null requestedKeys' then map gtKey globalTasks else requestedKeys' ++ builtinKeys + requestedKeys <- taskKeysForFiles pathsRoot rootProj globalTasks srcFiles + let builtinKeys = [ gtKey t | t <- globalTasks, tkMod (gtKey t) == A.modName ["__builtin__"] ] + startKeys = if null requestedKeys then map gtKey globalTasks else requestedKeys ++ builtinKeys depMapSet = M.fromList [ (gtKey t, Data.Set.fromList (M.elems (gtImportProviders t))) | t <- globalTasks ] neededKeys = reachable depMapSet (Data.Set.fromList startKeys) return [ t | t <- globalTasks, Data.Set.member (gtKey t) neededKeys ] where - lookupTaskKey ts f = do - absF <- canonicalizePath f - let byPath = listToMaybe [ gtKey t - | t <- ts - , let k = gtKey t - pths = gtPaths t - , srcFile pths (tkMod k) == absF - ] - case byPath of - Just k -> return (Just k) - Nothing -> do - mn <- moduleNameFromFile (srcDir pathsRoot) (projName pathsRoot) absF - return $ listToMaybe [ gtKey t - | t <- ts - , tkProj (gtKey t) == rootProj - , tkMod (gtKey t) == mn - ] - reachable depMap start = go (Data.Set.toList start) Data.Set.empty where go [] seen = seen @@ -1752,8 +1794,9 @@ dbpProviderPathClosure rootProj opts globalTasks dbpBlocked depMap revMap affect case M.lookup k taskMap of Just t -> case gtTask t of - TyTask{ tyImplHash = implHash, tyNameCount = nameCount } -> - isJust (dbpDeferredBackJob (Data.Set.member k dbpBlocked) False (optsFor k) (gtPaths t) (tkMod k) implHash nameCount) + TyTask{} -> + isJust (selectiveDeferredBackJob (Data.Set.member k dbpBlocked) False + (optsFor k) (gtPaths t) (tkMod k)) _ -> False Nothing -> False @@ -1782,11 +1825,12 @@ dbpProviderPathClosure rootProj opts globalTasks dbpBlocked depMap revMap affect seen' = Data.Set.insert k seen in reverseReachable seen' (ks ++ deps) --- | DBP may prune generated C/H for internal library modules, but a module at --- an explicit library boundary must keep its full generated surface. +-- | A declared library's exposed modules keep their complete generated +-- surface. Internal providers remain selective: the persisted whole-module +-- reach summary of each exposed module supplies their exact interest. libraryBoundaryTasks :: M.Map FilePath ProjCtx -> [GlobalTask] -> Data.Set.Set TaskKey libraryBoundaryTasks projMap globalTasks = - Data.Set.unions (map boundaryFor libraryGroups) + Data.Set.unions $ map exposedModules libraryGroups where taskKeys = Data.Set.fromList (map gtKey globalTasks) revMap = foldl' @@ -1799,11 +1843,14 @@ libraryBoundaryTasks projMap globalTasks = globalTasks libraryGroups = libraryTaskGroups projMap globalTasks - boundaryFor group = - Data.Set.filter hasOutsideConsumer group + exposedModules group = Data.Set.filter exposed group where - hasOutsideConsumer k = - any (`Data.Set.notMember` group) (M.findWithDefault [] k revMap) + exposed key = + null internalConsumers || not (null externalConsumers) + where + consumers = M.findWithDefault [] key revMap + (internalConsumers,externalConsumers) = partition + (`Data.Set.member` group) consumers moduleStringToName :: String -> A.ModName moduleStringToName = A.modName . splitMod @@ -2224,16 +2271,16 @@ readIfaceFromTy paths mn src mHash = do _ -> return $ Left (missingIfaceDiagnostics mn src mn) --- | Snapshot of expected/recorded impl hashes for generated code. +-- | Snapshot of expected and recorded hashes for generated code. data CodegenStatus = CodegenStatus { csExpected :: String , csC :: Maybe String , csH :: Maybe String } --- | Header prefix used to tag generated code with the module impl hash. +-- | Header prefix used to tag generated code with its exact codegen hash. codegenHashTag :: String -codegenHashTag = "/* Acton impl hash:" +codegenHashTag = "/* Acton codegen hash:" -- | Parse a tagged hash line from generated output. extractCodegenHash :: String -> Maybe String @@ -2257,15 +2304,15 @@ readCodegenHash path = do -- | Collect codegen hash status for a module. codegenStatus :: Paths -> A.ModName -> B.ByteString -> IO CodegenStatus -codegenStatus paths mn implHash = do - let expected = B.unpack $ Base16.encode implHash +codegenStatus paths mn codegenHash = do + let expected = B.unpack $ Base16.encode codegenHash cFile = outBase paths mn ++ ".c" hFile = outBase paths mn ++ ".h" cHash <- readCodegenHash cFile hHash <- readCodegenHash hFile return CodegenStatus { csExpected = expected, csC = cHash, csH = hHash } --- | Check whether generated .c/.h hashes match the expected impl hash. +-- | Check whether generated .c/.h hashes match the expected codegen hash. codegenUpToDate :: CodegenStatus -> Bool codegenUpToDate status = csC status == Just (csExpected status) && csH status == Just (csExpected status) @@ -2277,9 +2324,9 @@ formatCodegenDelta status = short actual = maybe "missing" (take 8) actual in case (csC status, csH status) of (Just c, Just h) | c == h -> - " {impl " ++ take 8 c ++ " -> " ++ expected ++ "}" + " {codegen " ++ take 8 c ++ " -> " ++ expected ++ "}" _ -> - " {impl c " ++ short (csC status) ++ " -> " ++ expected + " {codegen c " ++ short (csC status) ++ " -> " ++ expected ++ ", h " ++ short (csH status) ++ " -> " ++ expected ++ "}" -- | Run the front passes for a single module. @@ -2292,6 +2339,7 @@ formatCodegenDelta status = runFrontPasses :: C.GlobalOptions -> C.CompileOptions -> Bool + -> Bool -> Paths -> Acton.Env.Env0 -> A.Module @@ -2308,7 +2356,7 @@ runFrontPasses :: C.GlobalOptions -> IO Bool -> ([FrontOutputJob] -> IO ()) -> IO (Either [Diagnostic String] FrontResult) -runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourceMeta resolveImportHash resolveImportImplHash resolveNameHash onFrontProgress onFrontOutputStart onFrontOutputProgress onFrontOutputDone shouldWriteFrontOutput recordFrontOutputJobs = do +runFrontPasses gopts opts dbpBlocked requested paths env0 parsed srcContent srcBytes sourceMeta resolveImportHash resolveImportImplHash resolveNameHash onFrontProgress onFrontOutputStart onFrontOutputProgress onFrontOutputDone shouldWriteFrontOutput recordFrontOutputJobs = do createDirectoryIfMissing True (getModPath (projTypes paths) mn) core `catch` handleGeneral @@ -2376,10 +2424,29 @@ runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourc errsToDiagnostics "Compilation error" filename srcContent [(NoLoc, "Hash info missing for " ++ prstr qn)] - missingDepHashDiagnostics :: String -> A.Name -> SrcLoc -> A.QName -> [Diagnostic String] + missingDepHashDiagnostics :: String -> String -> SrcLoc -> A.QName -> [Diagnostic String] missingDepHashDiagnostics label owner loc qn = errsToDiagnostics "Compilation error" filename srcContent - [(loc, label ++ " hash missing for " ++ prstr qn ++ " (used by " ++ A.nstr owner ++ ")")] + [(loc, label ++ " hash missing for " ++ prstr qn ++ " (used by " ++ owner ++ ")")] + + resolveDepHash :: String + -> (InterfaceFiles.NameHashInfo -> B.ByteString) + -> String + -> SrcLoc + -> A.QName + -> IO (Either [Diagnostic String] (A.QName, B.ByteString)) + resolveDepHash label getHash owner loc qn = case qn of + A.GName m n -> lookupName m n + A.QName m n -> lookupName m n + A.NoQ _ -> return (Left (missingNameHashDiagnostics qn)) + where + lookupName m n = do + mInfo <- resolveNameHash m n + return $ case mInfo of + Just info + | not (B.null (getHash info)) -> Right (A.GName m n, getHash info) + | otherwise -> Left (missingDepHashDiagnostics label owner loc (A.GName m n)) + Nothing -> Left (missingNameHashDiagnostics (A.GName m n)) resolveDepHashes :: String -> (InterfaceFiles.NameHashInfo -> B.ByteString) @@ -2388,27 +2455,23 @@ runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourc -> IO (Either [Diagnostic String] (M.Map A.Name [(A.QName, B.ByteString)])) resolveDepHashes label getHash deps nameLocs = do resolved <- forM (M.toList deps) $ \(owner, qns) -> do - resolvedQns <- forM qns $ \qn -> case qn of - A.GName m n -> lookupName owner m n - A.QName m n -> lookupName owner m n - A.NoQ _ -> return (Left (missingNameHashDiagnostics qn)) + let loc = M.findWithDefault NoLoc owner nameLocs + resolvedQns <- forM qns (resolveDepHash label getHash (A.nstr owner) loc) let (errs, vals) = partitionEithers resolvedQns return $ if null errs - then Right (owner, catMaybes vals) + then Right (owner, vals) else Left (concat errs) let (errs, vals) = partitionEithers resolved return $ if null errs then Right (M.fromList vals) else Left (concat errs) - where - lookupName owner m n = do - mInfo <- resolveNameHash m n - return $ case mInfo of - Just info -> - let h = getHash info - loc = M.findWithDefault NoLoc owner nameLocs - in if B.null h - then Left (missingDepHashDiagnostics label owner loc (A.GName m n)) - else Right (Just (A.GName m n, h)) - Nothing -> Left (missingNameHashDiagnostics (A.GName m n)) + + resolveModuleDepHashes :: String + -> (InterfaceFiles.NameHashInfo -> B.ByteString) + -> [A.QName] + -> IO (Either [Diagnostic String] [(A.QName, B.ByteString)]) + resolveModuleDepHashes label getHash qns = do + resolved <- mapM (resolveDepHash label getHash "module initialization" NoLoc) qns + let (errs, vals) = partitionEithers resolved + return $ if null errs then Right vals else Left (concat errs) emitFrontProgress pass completed total current = onFrontProgress FrontPassProgress @@ -2507,9 +2570,31 @@ runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourc let I.NModule imps fullIface mdoc = nmod publicIface = publicIfaceTE fullIface let roots = [ n | (n,i) <- fullIface, rootEligible i ] - -- Extract top-level items from parsed and typed ASTs for per-name hashes. - let srcItems = Hashing.topLevelItems parsed - implItems = Hashing.topLevelItems tchecked + hashEnv = setMod mn env + -- Constructor partitioning follows the backend tree, whose imported + -- protocols have already become generated sibling classes. + rowEnv = define fullIface (setMod mn typeEnv) + moduleRows = + case Reachability.prepareInterfaceRows rowEnv tchecked of + Left (InterfaceRows.RowError msg) -> + error ("Internal error while preparing .tydb rows for " ++ + modNameToString mn ++ ": " ++ msg) + Right rows -> rows + reachabilityRows = + case Reachability.prepareReachabilityRows typeEnv fullIface tchecked moduleRows of + Left (InterfaceRows.RowError msg) -> + error ("Internal error while preparing reachability rows for " ++ + modNameToString mn ++ ": " ++ msg) + Right rows -> rows + topLevelOwners = map InterfaceRows.storedStmtNames (InterfaceRows.rowStatements moduleRows) + moduleStatements = + [ stmt + | InterfaceRows.StoredWhole [] stmt <- InterfaceRows.rowStatements moduleRows + ] + -- Parsed and typed fragments use the same ownership partition that + -- is persisted for selective reconstruction. + srcItems = Hashing.sourceTopLevelItems parsed + implItems = Hashing.topLevelItems topLevelOwners tchecked -- NameInfo defines the full local environment for this module. nameInfoMap = M.fromList fullIface nameLocsParsed = M.fromListWith (\a _ -> a) @@ -2521,7 +2606,6 @@ runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourc M.fromListWith (\a _ -> a) [ (n, A.sloc s) | Hashing.TLStmt n s <- implItems ] nameLocs = M.union nameLocsParsed nameLocsTyped - hashEnv = setMod mn env sourceHashWork = length srcItems implHashWork = length implItems ifaceHashWork = M.size nameInfoMap @@ -2538,6 +2622,8 @@ runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourc let completed = base + done when (completed `rem` hashProgressCheckStride == 0) $ emitHashProgressPaced False completed hashProgressTotal Nothing + evaluate (rnf moduleRows) + evaluate (rnf reachabilityRows) evaluate (sourceHashWork + implHashWork + ifaceHashWork + ifaceDepWork + implDepWork + M.size nameLocs) emitHashProgressPaced True 0 hashProgressTotal Nothing -- Module-level src hash uses raw bytes so any source edit forces re-parse. @@ -2563,7 +2649,11 @@ runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourc implItems evaluate (rnf nameImplHashes) let nameKeys = M.keysSet nameSrcHashes `Data.Set.union` M.keysSet nameImplHashes - evaluate (rnf nameKeys) + moduleOwnHash = Hashing.moduleOwnImplHash (A.importsOf tchecked) moduleStatements + (moduleLocalDeps, moduleImplExtDeps) = + Hashing.moduleImplSplitDeps mn hashEnv nameKeys moduleStatements + modulePubExtDeps = Hashing.publicImplDeps moduleImplExtDeps + evaluate (rnf (nameKeys, moduleOwnHash, moduleLocalDeps, modulePubExtDeps, moduleImplExtDeps)) selfPubHashes <- Hashing.nameInfoHashesWithProgress (hashProgress afterImplHashes) @@ -2586,7 +2676,11 @@ runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourc -- a pub hash. let (pubLocalDeps, pubExtDeps) = Hashing.mergePubDeps pubSigLocalDeps pubSigExtDeps implLocalDeps implExtDeps - extMods = Data.Set.toList (Hashing.externalModules pubExtDeps `Data.Set.union` Hashing.externalModules implExtDeps) + extMods = Data.Set.toList $ + Hashing.externalModules (concat $ M.elems pubExtDeps) `Data.Set.union` + Hashing.externalModules (concat $ M.elems implExtDeps) `Data.Set.union` + Hashing.externalModules modulePubExtDeps `Data.Set.union` + Hashing.externalModules moduleImplExtDeps evaluate (rnf (pubLocalDeps, pubExtDeps, extMods)) depModulesRes <- resolveDepModuleHashes extMods case depModulesRes of @@ -2596,16 +2690,26 @@ runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourc pubSigExtRes <- resolveDepHashes "pub" InterfaceFiles.nhPubHash pubSigExtDeps nameLocs pubExtRes <- resolveDepHashes "pub" InterfaceFiles.nhPubHash pubExtDeps nameLocs implExtRes <- resolveDepHashes "impl" InterfaceFiles.nhImplHash implExtDeps nameLocs - case (pubSigExtRes, pubExtRes, implExtRes) of - (Left diags, _, _) -> return (Left diags) - (_, Left diags, _) -> return (Left diags) - (_, _, Left diags) -> return (Left diags) - (Right pubSigExtHashes, Right pubExtHashes, Right implExtHashes) -> do - evaluate (rnf (pubSigExtHashes, pubExtHashes, implExtHashes)) + modulePubExtRes <- resolveModuleDepHashes "pub" InterfaceFiles.nhPubHash modulePubExtDeps + moduleImplExtRes <- resolveModuleDepHashes "impl" InterfaceFiles.nhImplHash moduleImplExtDeps + case (pubSigExtRes, pubExtRes, implExtRes, modulePubExtRes, moduleImplExtRes) of + (Left diags, _, _, _, _) -> return (Left diags) + (_, Left diags, _, _, _) -> return (Left diags) + (_, _, Left diags, _, _) -> return (Left diags) + (_, _, _, Left diags, _) -> return (Left diags) + (_, _, _, _, Left diags) -> return (Left diags) + (Right pubSigExtHashes, Right pubExtHashes, Right implExtHashes, + Right modulePubExtHashes, Right moduleImplExtHashes) -> do + evaluate (rnf (pubSigExtHashes, pubExtHashes, implExtHashes, + modulePubExtHashes, moduleImplExtHashes)) let pubHashes = Hashing.computeHashesSortedDeps selfPubHashes pubSigLocalDeps pubSigExtHashes implHashes = Hashing.computeHashesSortedDeps nameImplHashes implLocalDeps implExtHashes - (modulePubHash, moduleImplHash) = Hashing.moduleHashesFromHashMaps nmod nameKeys pubHashes implHashes - evaluate (rnf (pubHashes, implHashes, modulePubHash, moduleImplHash)) + moduleHashInfo = Hashing.finishModuleHash + implHashes moduleOwnHash topLevelOwners moduleLocalDeps + modulePubExtHashes moduleImplExtHashes + (modulePubHash, moduleImplHash) = + Hashing.moduleHashesFromHashMaps nmod moduleHashInfo nameKeys pubHashes implHashes + evaluate (rnf (pubHashes, implHashes, moduleHashInfo, modulePubHash, moduleImplHash)) let nameHashes = Hashing.assembleNameHashes nameKeys @@ -2628,32 +2732,47 @@ runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourc timeTypeCheck <- getTime Monotonic let writeTyDb outputKey = do - InterfaceFiles.writeFileWithProgress + InterfaceFiles.writeFile (\p -> onFrontOutputProgress outputKey FrontOutputTydb (frontOutputTyDbProgress p)) - A.version (tyDbPath paths mn) - moduleSrcBytesHash modulePubHash moduleImplHash sourceMeta impsWithHash depModules nameHashes roots tests mdoc nmod tchecked - writeDoc = do - let docDir = joinPath [projPath paths, "out", "doc"] - modPathList = A.modPath mn - docFile = if null modPathList - then docDir "unnamed" <.> "html" - else joinPath (docDir : init modPathList) last modPathList <.> "html" - docFileDir = takeDirectory docFile - -- Get the type environment for this module - modTypeEnv = case Acton.Env.lookupModuleInfo mn typeEnv of - Just mi -> Acton.Env.modulePublicTEnv mi - Nothing -> publicIface - -- Apply the same simplification as --sigs uses - env1 = define publicIface $ setMod mn env - simplifiedTypeEnv = simp env1 modTypeEnv - createDirectoryIfMissing True docFileDir - -- Use parsed (original AST) to preserve docstrings - let htmlDoc = DocP.printHtmlDoc (I.NModule imps simplifiedTypeEnv mdoc) parsed - writeFile docFile htmlDoc + InterfaceFiles.InterfaceContents + { InterfaceFiles.ifcSourceHash = moduleSrcBytesHash + , InterfaceFiles.ifcPublicHash = modulePubHash + , InterfaceFiles.ifcImplementationHash = moduleImplHash + , InterfaceFiles.ifcModuleHashInfo = moduleHashInfo + , InterfaceFiles.ifcSourceMeta = sourceMeta + , InterfaceFiles.ifcImports = impsWithHash + , InterfaceFiles.ifcDependencies = depModules + , InterfaceFiles.ifcNameHashes = nameHashes + , InterfaceFiles.ifcRoots = roots + , InterfaceFiles.ifcTests = tests + , InterfaceFiles.ifcDoc = mdoc + , InterfaceFiles.ifcModule = nmod + , InterfaceFiles.ifcRows = moduleRows + , InterfaceFiles.ifcReachabilityRows = reachabilityRows + } docOutputActions = if shouldGenerateDocOutput opts (isTmp paths) (length nameHashes) - then [(FrontOutputDoc, writeDoc)] + then + let writeDoc = do + let docDir = joinPath [projPath paths, "out", "doc"] + modPathList = A.modPath mn + docFile = if null modPathList + then docDir "unnamed" <.> "html" + else joinPath (docDir : init modPathList) last modPathList <.> "html" + docFileDir = takeDirectory docFile + -- Get the type environment for this module + modTypeEnv = case Acton.Env.lookupModuleInfo mn typeEnv of + Just mi -> Acton.Env.modulePublicTEnv mi + Nothing -> publicIface + -- Apply the same simplification as --sigs uses + env1 = define publicIface $ setMod mn env + simplifiedTypeEnv = simp env1 modTypeEnv + createDirectoryIfMissing True docFileDir + -- Use parsed (original AST) to preserve docstrings + let htmlDoc = DocP.printHtmlDoc (I.NModule imps simplifiedTypeEnv mdoc) parsed + writeFile docFile htmlDoc + in [(FrontOutputDoc, writeDoc)] else [] typeStmtTimings <- reverse <$> readIORef typeStmtTimingsRef typeProgressDone <- readIORef typeProgressDoneRef @@ -2681,19 +2800,29 @@ runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourc , ftTypeStmtTimings = typeStmtTimings } else Nothing - deferredBackJob = dbpDeferredBackJob dbpBlocked (A.hasNotImpl (A.mbody tchecked)) opts paths mn moduleImplHash (length nameHashes) + backPassNeeded = shouldRunBackPass dbpBlocked requested opts roots + deferredBackJob + | backPassNeeded = selectiveDeferredBackJob dbpBlocked + (A.hasNotImpl (A.mbody tchecked)) opts paths mn + | otherwise = Nothing backJob = case deferredBackJob of Just _ -> Nothing - Nothing -> + Nothing | backPassNeeded -> Just BackJob { bjPaths = paths , bjOpts = opts , bjInput = BackInput { biTypeEnv = typeEnv , biTypedMod = tchecked - , biSrc = srcContent - , biImplHash = moduleImplHash + , biDeclarations = [] + , biSrc = Just srcContent + , biCodegenHash = Hashing.wholeCodegenHash + (not $ C.dbg_no_lines opts) + moduleImplHash moduleSrcBytesHash } } + Nothing -> Nothing + evaluate backJob + evaluate docOutputActions do let outputKey = TaskKey (projPath paths) mn -- The .tydb commit is synchronous with front completion: @@ -2719,242 +2848,37 @@ runFrontPasses gopts opts dbpBlocked paths env0 parsed srcContent srcBytes sourc let jobs = docJobs ++ tyJobs recordFrontOutputJobs jobs return jobs - return $ Right FrontResult { frIfaceTE = publicIface - , frImps = imps - , frDoc = mdoc - , frModuleInfo = Nothing - , frPubHash = modulePubHash - , frImplHash = moduleImplHash - , frNameHashes = publicNameHashes nameHashes - , frInterestDeps = interestDepsFromNameHashes nameHashes - , frFrontTime = frontTimeMaybe - , frFrontTiming = frontTimingMaybe - , frInferredSigs = inferredSigs - , frBackJob = backJob - , frDeferredBackJob = deferredBackJob - , frOutputJobs = outputJobs - } - -data DbpSelection = DbpSelection - { dbsModule :: A.Module - , dbsSelectedCount :: Int - , dbsFallbackReason :: Maybe String - } - -data DbpNameSelection = DbpNameSelection - { dnsSelectedNames :: Data.Set.Set A.Name - , dnsNameHashes :: [InterfaceFiles.NameHashInfo] - } - -prepareDeferredBackJob :: Source.SourceProvider - -> C.GlobalOptions - -> CompileCallbacks - -> Acton.Env.Env0 - -> InterestMap - -> DeferredBackJob - -> IO (Maybe BackJob) -prepareDeferredBackJob sp gopts callbacks envAcc interestMap dbj = do - let paths = dbjPaths dbj - mn = dbjMod dbj - tyFile = tyDbPath paths mn - actFile = srcFile paths mn - roots <- InterfaceFiles.readRoots tyFile - let interested = M.findWithDefault Data.Set.empty mn interestMap - rootSeeds = Data.Set.fromList roots - selectedSeeds = Data.Set.union interested rootSeeds - totalNames = dbjNameCount dbj - nameSelection <- selectDbpNames paths mn tyFile selectedSeeds - let codegenHash = dbpCodegenHash (dbjImplHash dbj) (dnsSelectedNames nameSelection) - codegen <- codegenStatus paths mn codegenHash - if codegenUpToDate codegen - then do - logDbpSelection gopts callbacks mn dbj totalNames (Data.Set.size interested) (Data.Set.size rootSeeds) (Data.Set.size (dnsSelectedNames nameSelection)) Nothing "generated code up to date" - return Nothing - else do - selectedTmod <- InterfaceFiles.readSelectedModule tyFile (dnsNameHashes nameSelection) (dnsSelectedNames nameSelection) - -- Same-version .tydb files always carry statement indices, so a failed - -- selective read means a corrupt or hand-doctored file -- an eager - -- whole-module fallback would mask that (and read gigabytes doing it). - selection <- case selectedTmod of - Just tmod -> return $ selectDbpModule totalNames nameSelection tmod - Nothing -> error ("Internal error: missing statement rows in " ++ tyFile) - snap <- Source.readSource sp actFile - env1 <- Acton.Env.mkEnv (searchPath paths) envAcc (dbsModule selection) - logDbpSelection gopts callbacks mn dbj totalNames (Data.Set.size interested) (Data.Set.size rootSeeds) (dbsSelectedCount selection) (dbsFallbackReason selection) "generated code out of date" - return $ Just BackJob - { bjPaths = paths - , bjOpts = dbjOpts dbj - , bjInput = BackInput - { biTypeEnv = Converter.convEnvProtos env1 - , biTypedMod = dbsModule selection - , biSrc = Source.ssText snap - , biImplHash = codegenHash - } - } - -logDbpSelection :: C.GlobalOptions - -> CompileCallbacks - -> A.ModName - -> DeferredBackJob - -> Int - -> Int - -> Int - -> Int - -> Maybe String - -> String - -> IO () -logDbpSelection gopts callbacks mn dbj totalNames interestedCount rootCount selectedCount fallbackReason codegenReason = - when (C.verbose gopts) $ - ccOnInfo callbacks $ - " DBP " ++ modNameToString (dropProjPrefix (dbjPaths dbj) mn) - ++ ": total names " ++ show totalNames - ++ ", interested names " ++ show interestedCount - ++ ", root names " ++ show rootCount - ++ ", selected closure " ++ show selectedCount - ++ maybe "" (\reason -> ", fallback: " ++ reason) fallbackReason - ++ ", " ++ codegenReason - -dbpCodegenHash :: B.ByteString -> Data.Set.Set A.Name -> B.ByteString -dbpCodegenHash moduleImplHash selected = - SHA256.hash (BL.toStrict (encode ("dbp" :: String, moduleImplHash, selectedNames))) - where - selectedNames = - [ Hashing.nameKey n - | n <- Data.List.sortOn Hashing.nameKey (Data.Set.toList selected) - ] - -selectDbpNames :: Paths - -> A.ModName - -> FilePath - -> Data.Set.Set A.Name - -> IO DbpNameSelection -selectDbpNames paths mn tyFile seeds - | Data.Set.null seeds = - return DbpNameSelection - { dnsSelectedNames = Data.Set.empty - , dnsNameHashes = [] - } - | otherwise = do - roots <- traverse (dbpReadOwningName paths mn tyFile) (Data.Set.toList seeds) - selected <- dbpNameHashClosure paths mn tyFile M.empty roots - return DbpNameSelection - { dnsSelectedNames = Data.Set.fromList (M.keys selected) - , dnsNameHashes = M.elems selected - } - -dbpSelectionError :: Paths -> A.ModName -> String -> IO a -dbpSelectionError paths mn reason = - throwIO (DbpSelectionError ("DBP selection failed for " ++ modNameToString (dropProjPrefix paths mn) ++ ": " ++ reason)) - -selectDbpModule :: Int - -> DbpNameSelection - -> A.Module - -> DbpSelection -selectDbpModule totalNames nameSelection tmod@(A.Module loc imps mdoc suite) - | A.hasNotImpl suite = fallback "module contains NotImplemented/native extension hooks" - | otherwise = - let selected = dnsSelectedNames nameSelection - suite' = mapMaybe (dbpPruneTopStmt selected) suite - in DbpSelection - { dbsModule = A.Module loc imps mdoc suite' - , dbsSelectedCount = Data.Set.size selected - , dbsFallbackReason = Nothing - } - where - fallback reason = - DbpSelection - { dbsModule = tmod - , dbsSelectedCount = totalNames - , dbsFallbackReason = Just reason - } - -dbpReadNameHash :: Paths -> A.ModName -> FilePath -> A.Name -> IO InterfaceFiles.NameHashInfo -dbpReadNameHash paths mn tyFile n = do - mnh <- InterfaceFiles.readNameHashMaybe tyFile n - case mnh of - Just nh -> return nh - Nothing -> dbpSelectionError paths mn ("hash info missing for " ++ nameToString n) - -dbpReadOwningName :: Paths -> A.ModName -> FilePath -> A.Name -> IO A.Name -dbpReadOwningName paths mn tyFile n = do - mnh <- InterfaceFiles.readNameHashMaybe tyFile n - case mnh of - Just _ -> return n - Nothing -> - case n of - A.Derived base _ -> dbpReadOwningName paths mn tyFile base - _ | Names.isWitness n -> dbpSelectionError paths mn ("unresolved witness owner for " ++ nameToString n) - _ -> dbpSelectionError paths mn ("no top-level owner for " ++ nameToString n) - -dbpNameHashClosure :: Paths - -> A.ModName - -> FilePath - -> M.Map A.Name InterfaceFiles.NameHashInfo - -> [A.Name] - -> IO (M.Map A.Name InterfaceFiles.NameHashInfo) -dbpNameHashClosure _ _ _ selected [] = return selected -dbpNameHashClosure paths mn tyFile selected (n:ns) - | M.member n selected = dbpNameHashClosure paths mn tyFile selected ns - | otherwise = do - nh <- dbpReadNameHash paths mn tyFile n - localDeps <- traverse (dbpReadOwningName paths mn tyFile) - (InterfaceFiles.nhPubLocalDeps nh ++ InterfaceFiles.nhImplLocalDeps nh) - exts <- dbpExtensionsForName tyFile n - extDeps <- traverse (dbpReadOwningName paths mn tyFile) exts - let deps = unionNames localDeps extDeps - selected' = M.insert n nh selected - new = filter (`M.notMember` selected') deps - dbpNameHashClosure paths mn tyFile selected' (new ++ ns) - where - unionNames xs ys = Data.List.sortOn Hashing.nameKey (Data.List.nub (xs ++ ys)) - -dbpExtensionsForName :: FilePath -> A.Name -> IO [A.Name] -dbpExtensionsForName tyFile n = do - byClass <- InterfaceFiles.readExtensionsByClass tyFile n - byProtocol <- InterfaceFiles.readExtensionsByProtocol tyFile n - return (Data.List.sortOn Hashing.nameKey (Data.List.nub (byClass ++ byProtocol))) - -dbpPruneTopStmt :: Data.Set.Set A.Name -> A.Stmt -> Maybe A.Stmt -dbpPruneTopStmt selected stmt = - case stmt of - A.Decl l ds -> - case filter (\d -> Data.Set.member (Names.dname' d) selected) ds of - [] -> Nothing - ds' -> Just (A.Decl l ds') - A.Signature l ns typ dec -> - case filter (`Data.Set.member` selected) ns of - [] -> Nothing - ns' -> Just (A.Signature l ns' typ dec) - A.Assign{} -> - if any (`Data.Set.member` selected) (Names.bound stmt) - then Just stmt - else Nothing - A.VarAssign{} -> - if any (`Data.Set.member` selected) (Names.bound stmt) - then Just stmt - else Nothing - A.Pass{} -> Nothing - -- Source-level modules only admit Decl, Signature, and Assign at the top - -- level. VarAssign and Pass are compiler-introduced typed forms handled - -- above; other statement forms should not appear in a typed module suite. - _ -> Nothing - + ifaceRes <- readIfaceFromTy paths mn srcContent (Just modulePubHash) + case ifaceRes of + Left diags -> return (Left diags) + Right (_,_,_,_,_,moduleInfo) -> + return $ Right FrontResult + { frIfaceTE = [] + , frImps = imps + , frDoc = mdoc + , frModuleInfo = moduleInfo + , frPubHash = modulePubHash + , frImplHash = moduleImplHash + , frNameHashes = publicNameHashes nameHashes + , frFrontTime = frontTimeMaybe + , frFrontTiming = frontTimingMaybe + , frInferredSigs = inferredSigs + , frBackJob = backJob + , frDeferredBackJob = deferredBackJob + , frOutputJobs = outputJobs + } -- | Run the back passes for a single module. -- Executes normalization through codegen, writes .c/.h output as needed, and -- returns the back-pass elapsed time for logging. -runBackPasses :: C.GlobalOptions -> C.CompileOptions -> Paths -> BackInput -> IO Bool -> IO (Maybe TimeSpec, Maybe BackTiming) -runBackPasses gopts opts paths backInput shouldWrite = - runBackPassesWithProgress gopts opts paths backInput shouldWrite (\_ -> return ()) - -runBackPassesWithProgress :: C.GlobalOptions - -> C.CompileOptions - -> Paths - -> BackInput - -> IO Bool - -> (BackPassProgress -> IO ()) - -> IO (Maybe TimeSpec, Maybe BackTiming) -runBackPassesWithProgress gopts opts paths backInput shouldWrite onProgress = do +runBackPasses :: C.GlobalOptions + -> C.CompileOptions + -> Paths + -> BackInput + -> (IO () -> IO Bool) + -> (BackPassProgress -> IO ()) + -> IO (Maybe TimeSpec, Maybe BackTiming) +runBackPasses gopts opts paths backInput commitWrite onProgress = do let mn = A.modname (biTypedMod backInput) outbase = outBase paths mn relSrcBase = makeRelative (projPath paths) (srcBase paths mn) @@ -3034,12 +2958,14 @@ runBackPassesWithProgress gopts opts paths backInput shouldWrite onProgress = do return res ((_,h,c), tCodeGen) <- timedBackPass BackPassCodeGen $ do - let hexHash = B.unpack $ Base16.encode (biImplHash backInput) - emitLines = not (C.dbg_no_lines opts) - Acton.CodeGen.generate liftEnv relSrcBase (biSrc backInput) emitLines boxed hexHash + let hexHash = B.unpack $ Base16.encode (biCodegenHash backInput) + srcText = fromMaybe "" (biSrc backInput) + emitLines = isJust (biSrc backInput) && not (C.dbg_no_lines opts) + Acton.CodeGen.generate liftEnv (biDeclarations backInput) + relSrcBase srcText emitLines boxed hexHash let finishBack = finish tNormalize tDeactorize tCPS tLLift tBoxing tCodeGen - if C.hgen opts + result <- if C.hgen opts then do (_, tRender) <- timedBackPass BackPassRender (forceOut h) putStrLn h @@ -3055,19 +2981,21 @@ runBackPassesWithProgress gopts opts paths backInput shouldWrite onProgress = do if not writesOutput then return Nothing else do - ok <- shouldWrite - if not ok + writeTime <- newIORef Nothing + wrote <- commitWrite $ do + (_, tWrite) <- timedBackPass BackPassWrite $ do + let cFile = outbase ++ ".c" + hFile = outbase ++ ".h" + writeFile hFile h + writeFile cFile c + writeIORef writeTime (Just tWrite) + if not wrote then do emitSkipped BackPassWrite return Nothing - else do - (_, tWrite) <- timedBackPass BackPassWrite $ do - let cFile = outbase ++ ".c" - hFile = outbase ++ ".h" - writeFile hFile h - writeFile cFile c - return (Just tWrite) + else readIORef writeTime finishBack tRender mWriteTime + return result -- | Compile a set of GlobalTasks using a parallel, dependency-aware scheduler. @@ -3124,11 +3052,13 @@ compileTasks :: Source.SourceProvider -> C.CompileOptions -> Paths -- root project paths (for alt output root selection) -> FilePath -- root project path + -> Data.Set.Set TaskKey -- root-project modules that can produce requested binaries + -> Data.Set.Set TaskKey -- explicitly requested modules -> [GlobalTask] -> Data.Set.Set TaskKey -> CompileCallbacks -> IO (Either CompileFailure (Acton.Env.Env0, Bool)) -compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do +compileTasks sp gopts opts rootPaths rootProj rootTaskKeys requestedTasks tasks dbpBlocked callbacks = do runningRef <- newIORef [] frontOutputRef <- newIORef [] let cancelRunning = do @@ -3182,7 +3112,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do nCaps <- getNumCapabilities let maxParallel = max 1 (if C.jobs gopts > 0 then C.jobs gopts else nCaps) - loop frontOutputRef runningRef stageInitialReady [] M.empty M.empty M.empty M.empty M.empty Data.Set.empty M.empty stageIndeg stagePending0 baseEnv False maxParallel cwMap + loop frontOutputRef runningRef stageInitialReady [] M.empty M.empty M.empty M.empty M.empty stageIndeg stagePending0 baseEnv False maxParallel cwMap -- Basic maps/sets ---------------------------------------------------- taskMap = M.fromList [ (gtKey t, t) | t <- tasks ] @@ -3251,6 +3181,25 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do stagePending0 = Data.Set.fromList (M.keys stageIndeg) rootAlt = modName rootPaths + rootAltKey = TaskKey rootProj rootAlt + + rootCandidates :: [(TaskKey,A.Name)] + rootCandidates + | C.test opts = + [ (key,A.name "test_main") | key <- Data.Set.toAscList rootTaskKeys ] + | not (null $ C.root opts) = [explicitRootCandidate] + | otherwise = + [ (key,A.name "main") | key <- Data.Set.toAscList rootTaskKeys ] + + explicitRootCandidate = + let parts = A.modPath (moduleStringToName $ C.root opts) + moduleParts = init parts + project = projName rootPaths + canonicalModule + | null moduleParts = rootAlt + | project `elem` special_projects = A.modName moduleParts + | otherwise = A.modName (project : moduleParts) + in (TaskKey rootProj canonicalModule,A.name $ last parts) builtinPath = case builtinOrder of @@ -3277,32 +3226,250 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do seen' = foldl' (flip Data.Set.insert) seen new in go seen' (new ++ xs) - flushReadyDeferredBacks :: Acton.Env.Env0 - -> InterestMap - -> Data.Set.Set TaskKey - -> M.Map TaskKey (DeferredBackJob, Data.Set.Set TaskKey) - -> IO (Either CompileFailure (M.Map TaskKey (DeferredBackJob, Data.Set.Set TaskKey))) - flushReadyDeferredBacks envAcc interestMap frontDone deferredBacks = do - let (ready, waiting) = - M.partitionWithKey - (\_ (_dbj, waitSet) -> waitSet `Data.Set.isSubsetOf` frontDone) - deferredBacks - prepared <- (try $ - forM (M.elems ready) $ \(dbj, _waitSet) -> do - mJob <- prepareDeferredBackJob sp gopts callbacks envAcc interestMap dbj - case mJob of - Nothing -> ccOnBackSkipped callbacks (TaskKey (projPath (dbjPaths dbj)) (dbjMod dbj)) - Just _ -> return () - return mJob) - :: IO (Either SomeException [Maybe BackJob]) + flushDeferredBacks :: M.Map TaskKey DeferredBackJob + -> IO (Either CompileFailure ()) + flushDeferredBacks deferredBacks | M.null deferredBacks = do + ccOnReachability callbacks Data.Set.empty Reachability.emptySelection + return (Right ()) + flushDeferredBacks deferredBacks = do + prepared <- (try prepareAll :: IO (Either SomeException [Maybe BackJob])) case prepared of - Left err -> - if isJust (fromException err :: Maybe SomeAsyncException) - then throwIO err - else return (Left (CompileInternalFailure (displayException err))) + Left err + | isJust (fromException err :: Maybe SomeAsyncException) -> throwIO err + | otherwise -> return (Left (CompileInternalFailure (displayException err))) Right jobs -> do mapM_ (ccOnBackJob callbacks) (catMaybes jobs) - return (Right waiting) + return (Right ()) + where + deferred = M.toAscList deferredBacks + taskInterfaces = M.fromListWith (++) + [ (tkMod key, [tyDbPath (gtPaths task) (tkMod key)]) + | task <- tasks + , let key = gtKey task + ] + searchPaths = nub (concatMap (searchPath . gtPaths) tasks) + + resolveInterface mn = + case M.findWithDefault [] mn taskInterfaces of + [] -> Acton.Env.findTyFile searchPaths mn + [path] -> return (Just path) + paths -> throwIO $ ProjectError + ("Selective back-pass module identity is ambiguous: " ++ + show (mn,paths)) + + prepareAll = do + let byModule = M.fromListWith (++) + [ (dbjMod dbj, [key]) | (key,dbj) <- deferred ] + ambiguous = [ (mn,keys) | (mn,keys) <- M.toAscList byModule, length keys > 1 ] + unless (null ambiguous) $ + throwIO $ ProjectError + ("Selective back-pass module identity is ambiguous: " ++ show ambiguous) + + let deferredKeys = Data.Set.fromList (map fst deferred) + selectableModules = Data.Set.fromList + [ dbjMod dbj | (_,dbj) <- deferred ] + wholeKeys0 = M.keysSet taskMap `Data.Set.difference` deferredKeys + wholeModules0 = Data.Set.fromList + [ tkMod key | key <- Data.Set.toAscList wholeKeys0 ] + interfaceModules = selectableModules `Data.Set.union` wholeModules0 + rootModules = + [ (tkMod key,root) + | (key,root) <- rootCandidates + , M.member key taskMap + ] + interfaces <- SelectiveBack.loadInterfaceClosure + resolveInterface interfaceModules + let rootlessModules = SelectiveBack.rootlessModules interfaces + noBackKeys + | altOutput opts = Data.Set.empty + | otherwise = Data.Set.filter + (\key -> Data.Set.notMember key dbpBlocked && + Data.Set.member key requestedTasks && + Data.Set.member (tkMod key) rootlessModules) + wholeKeys0 + wholeKeys = wholeKeys0 `Data.Set.difference` noBackKeys + wholeModules = Data.Set.fromList + [ tkMod key | key <- Data.Set.toAscList wholeKeys ] + notImplementedModules = + SelectiveBack.notImplementedModules interfaces + nativeRoots = Data.Set.filter + (\key -> Data.Set.member (tkMod key) notImplementedModules) + wholeKeys + nativeForcedKeys = providerClosure nativeRoots + `Data.Set.intersection` deferredKeys + (wholeDeferred,selectedDeferred) = partition + (\(key,_) -> Data.Set.member key nativeForcedKeys) + deferred + forcedWholeModules = Data.Set.fromList + [ dbjMod dbj | (_,dbj) <- wholeDeferred ] + interestWholeModules = wholeModules + `Data.Set.union` forcedWholeModules + rootSeeds <- SelectiveBack.rootSeeds interfaces rootModules + wholeSeeds <- SelectiveBack.wholeModuleSeeds interfaces interestWholeModules + selectedPreparation <- prepareSelected interfaces selectedDeferred + (rootSeeds ++ wholeSeeds) + case selectedPreparation of + Left () -> do + ccOnReachability callbacks + (interestWholeModules `Data.Set.union` selectableModules) + Reachability.emptySelection + wholeJobs <- prepareWholeModules interfaces deferred + return wholeJobs + Right (selection,selectiveJobs) -> do + ccOnReachability callbacks interestWholeModules selection + wholeJobs <- prepareWholeModules interfaces wholeDeferred + return (wholeJobs ++ selectiveJobs) + + prepareSelected _ [] _ = + return (Right (Reachability.emptySelection,[])) + prepareSelected _ selectedDeferred [] = do + mapM_ (ccOnBackSkipped callbacks . fst) selectedDeferred + return (Right (Reachability.emptySelection,[])) + prepareSelected interfaces selectedDeferred seeds = do + let selectableModules = Data.Set.fromList + [ dbjMod dbj | (_,dbj) <- selectedDeferred ] + selectedResult <- SelectiveBack.selectInterfaces + interfaces selectableModules seeds + case selectedResult of + Left Reachability.DynamicSerializationRequiresWhole -> + return (Left ()) + Left err -> throwIO $ ProjectError + ("Selective back-pass reachability failed: " ++ show err) + Right selectedProgram -> Right <$> prepareProjection selectedProgram + where + prepareProjection selectedProgram0 = do + (selectedProgram,opaqueHashes) <- + SelectiveBack.selectedOpaqueHashes resolveInterface selectedProgram0 + let activeInterfaces = SelectiveBack.selectedProgramInterfaces selectedProgram + selection = SelectiveBack.selectedProgramSelection selectedProgram + selectedModules = Data.Set.fromList + [ mn + | Reachability.TopKey mn _ <- + Data.Set.toAscList + ( Reachability.selectedTops selection + `Data.Set.union` Reachability.selectedDeclarations selection + ) + ] + projectionModules = selectedModules `Data.Set.union` + Data.Set.fromList [ dbjMod dbj | (_,dbj) <- selectedDeferred ] + projections <- SelectiveBack.materializeInterfaceProjections + (Data.Set.toAscList projectionModules) selectedProgram + let projectionMap = M.fromList + [ (A.modname $ SelectiveBack.projectionModule projection,projection) + | projection <- projections + ] + keyedProjections <- forM selectedDeferred $ \(key,dbj) -> + case M.lookup (dbjMod dbj) projectionMap of + Nothing -> throwIO $ ProjectError + ("Missing selective projection for " ++ modNameToString (dbjMod dbj)) + Just projection -> return (key,dbj,projection) + + let universeHash = SelectiveBack.bindInterfaces + (SelectiveBack.projectionUniverseHash selection projections opaqueHashes) + activeInterfaces + interfaceEnv <- SelectiveBack.interfaceEnvironment activeInterfaces + let selectiveEnv = SelectiveBack.restrictEnvironmentPublicNames + selection interfaceEnv + projectedEnv = foldl' installProjection selectiveEnv projections + installProjection env projection = + let mn = A.modname $ SelectiveBack.projectionModule projection + info = SelectiveBack.projectionModuleInfo env projection + in Acton.Env.addModuleInfo mn info env + + jobs <- forM keyedProjections $ \(key,dbj,projection) -> do + let paths = dbjPaths dbj + mn = dbjMod dbj + typed = SelectiveBack.projectionModule projection + codegenHash = SelectiveBack.projectionCodegenHash universeHash mn + status <- codegenStatus paths mn codegenHash + if codegenUpToDate status + then do + logSelection dbj projection "generated code up to date" + ccOnBackSkipped callbacks key + return Nothing + else do + importedEnv <- Acton.Env.mkEnv (searchPath paths) projectedEnv typed + let declarations = SelectiveBack.projectionDeclarations projection + env = Acton.Env.defineClosed declarations importedEnv + logSelection dbj projection "generated code out of date" + return $ Just BackJob + { bjPaths = paths + , bjOpts = dbjOpts dbj + , bjInput = BackInput + { biTypeEnv = Converter.convEnvProtos env + , biTypedMod = typed + , biDeclarations = map fst declarations + , biSrc = Nothing + , biCodegenHash = codegenHash + } + } + return (selection,jobs) + + providerClosure initial = go (Data.Set.toAscList initial) initial + where + go [] seen = seen + go (key:pending) seen = + let new = filter (`Data.Set.notMember` seen) $ + M.findWithDefault [] key depMap + seen' = foldl' (flip Data.Set.insert) seen new + in go (pending ++ new) seen' + + prepareWholeModules _ [] = return [] + prepareWholeModules interfaces wholeDeferred = do + interfaceEnv <- SelectiveBack.interfaceEnvironment interfaces + mapM (prepareWhole interfaces interfaceEnv) wholeDeferred + + prepareWhole interfaces interfaceEnv (key,dbj) = do + let paths = dbjPaths dbj + mn = dbjMod dbj + implHash <- SelectiveBack.interfaceImplementationHash interfaces mn + sourceHash <- SelectiveBack.interfaceSourceHash interfaces mn + let wholeHash = Hashing.wholeCodegenHash + (not $ C.dbg_no_lines $ dbjOpts dbj) implHash sourceHash + codegenHash = SelectiveBack.bindInterfaces wholeHash interfaces + status <- codegenStatus paths mn codegenHash + if codegenUpToDate status + then do + logWhole dbj "generated code up to date" + ccOnBackSkipped callbacks key + return Nothing + else do + (typed,storedImplHash) <- SelectiveBack.materializeWholeModule + interfaces mn + unless (storedImplHash == implHash) $ + throwIO $ ProjectError $ + "Interface changed while preparing full back pass for " ++ + modNameToString mn + env <- Acton.Env.mkEnv (searchPath paths) interfaceEnv typed + snap <- readMatchingSource sp mn sourceHash (srcFile paths mn) + logWhole dbj "generated code out of date" + return $ Just BackJob + { bjPaths = paths + , bjOpts = dbjOpts dbj + , bjInput = BackInput + { biTypeEnv = Converter.convEnvProtos env + , biTypedMod = typed + , biDeclarations = [] + , biSrc = Just (Source.ssText snap) + , biCodegenHash = codegenHash + } + } + + logSelection dbj projection reason = + when (C.verbose gopts) $ + ccOnInfo callbacks $ + " Selective back " ++ + modNameToString (dropProjPrefix (dbjPaths dbj) (dbjMod dbj)) ++ + ": " ++ show (SelectiveBack.projectionTopCount projection) ++ " tops, " ++ + show (SelectiveBack.projectionMemberCount projection) ++ " members, " ++ reason + + logWhole dbj reason = + when (C.verbose gopts) $ + ccOnInfo callbacks $ + " Full back " ++ + modNameToString (dropProjPrefix (dbjPaths dbj) (dbjMod dbj)) ++ + ": full-module closure, " ++ reason + -- TODO: can we reintegrate this into the normal loop to avoid duplication? -- NOTE: FYI, it was originally part of the main loop but factored out for @@ -3316,7 +3483,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do mn = name (gtTask t) optsBuiltin = optsFor (gtKey t) actFile = srcFile bPaths mn - forceAlt = altOutput optsBuiltin && mn == rootAlt + forceAlt = altOutput optsBuiltin && gtKey t == rootAltKey if C.only_build optsBuiltin then return (Right ()) else do @@ -3337,6 +3504,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do gopts optsBuiltin False + False bPaths builtinEnv0 m @@ -3391,7 +3559,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do actFile = srcFile paths mn tyFile = tyDbPath paths mn short8 bs = take 8 (B.unpack $ Base16.encode bs) - mkFrontResult imps ifaceTE mdoc pubHash implHash nameHashes interestNameHashes backJob deferredBackJob = + mkFrontResult imps ifaceTE mdoc pubHash implHash nameHashes backJob deferredBackJob = FrontResult { frIfaceTE = ifaceTE , frImps = imps @@ -3400,7 +3568,6 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do , frPubHash = pubHash , frImplHash = implHash , frNameHashes = nameHashes - , frInterestDeps = interestDepsFromNameHashes interestNameHashes , frFrontTime = Nothing , frFrontTiming = Nothing , frInferredSigs = [] @@ -3417,7 +3584,6 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do , frPubHash = B.empty , frImplHash = B.empty , frNameHashes = [] - , frInterestDeps = Data.Set.empty , frFrontTime = Nothing , frFrontTiming = Nothing , frInferredSigs = [] @@ -3449,15 +3615,16 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do case tyRes of Nothing -> return (Left (missingIfaceDiagnostics mn "" mn)) Just ty -> return (Right ty) - mkBackJob env1 tmod srcText moduleImplHash = + mkBackJob env1 tmod srcText codegenHash = BackJob { bjPaths = paths , bjOpts = optsT , bjInput = BackInput { biTypeEnv = Converter.convEnvProtos env1 , biTypedMod = tmod - , biSrc = srcText - , biImplHash = moduleImplHash + , biDeclarations = [] + , biSrc = Just srcText + , biCodegenHash = codegenHash } } @@ -3573,64 +3740,16 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do then "" else " (used by " ++ intercalate ", " names ++ ")" - interestDepsFromDepRows depModules = do - depSets <- forM depModules $ \depInfo -> do - let depMn = InterfaceFiles.dmiModule depInfo - depNames <- InterfaceFiles.readDepNames tyFile depMn - return (Data.Set.fromList [ (depMn, InterfaceFiles.dniName depName) | depName <- depNames ]) - return (Data.Set.unions depSets) - - cachedInterestDeps = case taskCurrent of - TyTask{ tyDepModules = depModules } -> interestDepsFromDepRows depModules - _ -> return Data.Set.empty - - -- Restore BOTH the pub and the impl per-name external deps from the - -- module-level dep rows (the per-name rows on disk are stripped, see - -- InterfaceFiles.stripExternalDeps). The impl half matters: a header - -- rewrite (impl-hash refresh) re-derives the dep rows from these name - -- hashes, and losing the impl users would erase the per-name impl - -- change tracking for every dependency of this module. - restorePubDepsFromRows depModules nameHashes = do - (pubByOwner, implByOwner) <- foldM addModule (M.empty, M.empty) depModules - -- Canonical order: the hash combinators (computeHashesSortedDeps) - -- require dep lists sorted by name, exactly as the front pass - -- stores them -- row iteration order must not leak into hashes. - return - [ nh { InterfaceFiles.nhPubDeps = Data.List.sortOn fst (M.findWithDefault [] (InterfaceFiles.nhName nh) pubByOwner) - , InterfaceFiles.nhImplDeps = Data.List.sortOn fst (M.findWithDefault [] (InterfaceFiles.nhName nh) implByOwner) - } - | nh <- nameHashes - ] - where - addModule acc depInfo = do - let depMn = InterfaceFiles.dmiModule depInfo - depNames <- InterfaceFiles.readDepNames tyFile depMn - foldM (addName depMn) acc depNames - - addName depMn (pubAcc, implAcc) depInfo = do - users <- InterfaceFiles.readDepUsers tyFile depMn (InterfaceFiles.dniName depInfo) - let mkDep h = - ( A.GName depMn (InterfaceFiles.dniName depInfo) - , h - ) - addUser dep m user = - M.insertWith (++) user [dep] m - pubAcc' - | B.null (InterfaceFiles.dniPubHash depInfo) = pubAcc - | otherwise = foldl' (addUser (mkDep (InterfaceFiles.dniPubHash depInfo))) pubAcc (InterfaceFiles.duPubUsers users) - implAcc' - | B.null (InterfaceFiles.dniImplHash depInfo) = implAcc - | otherwise = foldl' (addUser (mkDep (InterfaceFiles.dniImplHash depInfo))) implAcc (InterfaceFiles.duImplUsers users) - return (pubAcc', implAcc') - - depModulesFromNameHashes nameHashes = do + depModulesFromHashes moduleHashInfo nameHashes = do let depMods = - Data.List.sortOn modNameToString $ + Data.List.sort $ Data.Set.toList $ Data.Set.fromList [ depMn - | nh <- nameHashes - , (qn, _) <- InterfaceFiles.nhPubDeps nh ++ InterfaceFiles.nhImplDeps nh + | (qn, _) <- + InterfaceFiles.mhPubDeps moduleHashInfo ++ + InterfaceFiles.mhImplDeps moduleHashInfo ++ + concatMap (\nh -> InterfaceFiles.nhPubDeps nh ++ InterfaceFiles.nhImplDeps nh) nameHashes , depMn <- case qn of A.GName m _ -> [m] A.QName m _ -> [m] @@ -3713,6 +3832,11 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do return (fmap (\vals -> (n, vals)) resolvedQns)) (M.toList deps) return (fmap M.fromList resolved) + resolveModuleDepHashes label getHash qns = + traverseDiags (\qn -> do + currE <- resolveQNameHash label getHash " (used by module initialization)" qn + return (fmap (\curr -> (qn, curr)) currE)) qns + checkDepModuleRows depModules = do resolved <- traverseDiags checkOne depModules return $ fmap foldRows resolved @@ -3803,11 +3927,8 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do TyTask{ tyNameHashes = nhs } -> nhs _ -> [] cachedNameHashes = publicNameHashes cachedFullNameHashes - interestDeps <- cachedInterestDeps - let fr = (mkFrontResult imps ifaceTE mdoc ih implH cachedNameHashes cachedFullNameHashes Nothing Nothing) - { frModuleInfo = mModuleInfo - , frInterestDeps = interestDeps - } + let fr = (mkFrontResult imps ifaceTE mdoc ih implH cachedNameHashes Nothing Nothing) + { frModuleInfo = mModuleInfo } cacheFrontResult fr Left _ -> return (key, Right emptyFrontResult) @@ -3842,25 +3963,32 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do needByPub = not (null pubDeltas) needByMissing = not (null pubMissing) || not (null implMissing) || not (Data.Set.null rowMissingMods) needByImpl = not (null implDeltas) - forceAlt = altOutput optsT && mn == rootAlt + forceAlt = altOutput optsT && key == rootAltKey forceAlways = C.alwaysbuild optsT -- Front passes run on source or API changes, or when forced. needFront = needBySource || needByPub || needByMissing || forceAlt || forceAlways - mModuleImplHash = case taskCurrent of - TyTask{ tyImplHash = implHash } -> Just implHash + mCodegenHash = case taskCurrent of + TyTask{ tyHash = sourceHash, tyImplHash = implHash } -> + Just (Hashing.wholeCodegenHash + (not $ C.dbg_no_lines optsT) implHash sourceHash) _ -> Nothing + backPassNeeded = case taskCurrent of + TyTask{ tyRoots = roots } -> + shouldRunBackPass (isDbpBlocked key) + (Data.Set.member key requestedTasks) optsT roots + _ -> True cachedDeferredBackJob <- case taskCurrent of - TyTask{ tyImplHash = implHash, tyNameCount = nameCount } -> do + TyTask{} | backPassNeeded -> do hasNotImpl <- InterfaceFiles.readStmtHasNotImpl tyFile - return (dbpDeferredBackJob (isDbpBlocked key) hasNotImpl optsT paths mn implHash nameCount) + return (selectiveDeferredBackJob (isDbpBlocked key) hasNotImpl optsT paths mn) _ -> return Nothing let isCachedDbp = case cachedDeferredBackJob of Just _ -> True Nothing -> False - let canCheckCodegen = not needFront && not needByImpl && not (altOutput optsT) && not isCachedDbp - mCodegenStatus <- case mModuleImplHash of - Just implHash | canCheckCodegen -> Just <$> codegenStatus paths mn implHash + let canCheckCodegen = backPassNeeded && not needFront && not needByImpl && not (altOutput optsT) && not isCachedDbp + mCodegenStatus <- case mCodegenHash of + Just codegenHash | canCheckCodegen -> Just <$> codegenStatus paths mn codegenHash _ -> return Nothing let needByCodegen = maybe False (not . codegenUpToDate) mCodegenStatus let runFront = do @@ -3902,6 +4030,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do gopts optsT (isDbpBlocked key) + (Data.Set.member key requestedTasks) paths envSnap (adjustImports providers m) @@ -3954,18 +4083,27 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do -- only when the refresh must feed an EAGER back job -- then it -- is the compilation input. case taskCurrent of - TyTask{ tyDepModules = depModules, tyPubHash = storedPubHash } -> do - -- The task header carries only the name COUNT (selective - -- reads); the refresh needs the module's own hash rows. - storedNameHashes <- InterfaceFiles.readNameHashes tyFile - moduleHasNotImpl <- InterfaceFiles.readStmtHasNotImpl tyFile - restored <- restorePubDepsFromRows depModules storedNameHashes + TyTask{ tyHash = expectedSourceHash + , tyPubHash = expectedPublicHash + , tyImplHash = expectedImplHash + } -> do + refreshInput <- InterfaceFiles.readImplRefreshInput tyFile + unless (InterfaceFiles.iriSourceHash refreshInput == expectedSourceHash + && InterfaceFiles.iriPublicHash refreshInput == expectedPublicHash + && InterfaceFiles.iriImplementationHash refreshInput == expectedImplHash) $ + throwIO (InterfaceFiles.ImplRefreshStale + "Interface changed after dependency freshness was checked") + let storedNameHashes = InterfaceFiles.iriNameHashes refreshInput + storedModuleHash = InterfaceFiles.iriModuleHashInfo refreshInput + moduleHasNotImpl = InterfaceFiles.iriHasNotImpl refreshInput + storedPubHash = InterfaceFiles.iriPublicHash refreshInput + roots = InterfaceFiles.iriRoots refreshInput -- Only names with an impl item participate in the refresh -- -- exactly the names the front pass gave a (non-empty) own -- impl-hash component. A signature-only name's impl hash is -- invariant under dependency changes. let refreshables = - [ nh | nh <- restored + [ nh | nh <- storedNameHashes , not (B.null (InterfaceFiles.nhOwnImplHash nh)) ] ownImplHashes = M.fromList [ (InterfaceFiles.nhName nh, InterfaceFiles.nhOwnImplHash nh) | nh <- refreshables ] @@ -3974,20 +4112,36 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do implExtDeps = M.fromList [ (InterfaceFiles.nhName nh, map fst (InterfaceFiles.nhImplDeps nh)) | nh <- refreshables ] do - implExtRes <- (try :: IO a -> IO (Either SomeException a)) $ - resolveDepHashes "impl" InterfaceFiles.nhImplHash implExtDeps + implExtRes <- (try :: IO a -> IO (Either SomeException a)) $ do + nameDeps <- resolveDepHashes "impl" InterfaceFiles.nhImplHash implExtDeps + moduleDeps <- resolveModuleDepHashes "impl" InterfaceFiles.nhImplHash + (map fst (InterfaceFiles.mhImplDeps storedModuleHash)) + return (nameDeps, moduleDeps) case implExtRes of Left err -> handleSyncFailure err - Right (Left _) -> rerunFront - Right (Right implExtHashes) -> do + Right (Left _, _) -> rerunFront + Right (_, Left _) -> rerunFront + Right (Right implExtHashes, Right moduleImplExtHashes) -> do let updatedNameHashes = - Hashing.refreshImplHashes restored ownImplHashes implLocalDeps implExtHashes - moduleImplHash = Hashing.moduleImplHashFromNameHashes updatedNameHashes - depModulesRes <- depModulesFromNameHashes updatedNameHashes + Hashing.refreshImplHashes storedNameHashes ownImplHashes implLocalDeps implExtHashes + updatedImplHashes = M.fromList + [ (InterfaceFiles.nhName nh, InterfaceFiles.nhImplHash nh) + | nh <- updatedNameHashes + ] + updatedModuleHash = Hashing.finishModuleHash + updatedImplHashes + (InterfaceFiles.mhOwnImplHash storedModuleHash) + (InterfaceFiles.mhStatementOwners storedModuleHash) + (InterfaceFiles.mhImplLocalDeps storedModuleHash) + (InterfaceFiles.mhPubDeps storedModuleHash) + moduleImplExtHashes + moduleImplHash = + Hashing.moduleImplHashFromNameHashes updatedModuleHash updatedNameHashes + depModulesRes <- depModulesFromHashes updatedModuleHash updatedNameHashes case depModulesRes of Left _ -> rerunFront Right updatedDepModules -> do - evaluate (rnf (moduleImplHash, updatedDepModules, updatedNameHashes)) + evaluate (rnf (moduleImplHash, updatedModuleHash, updatedDepModules, updatedNameHashes)) let outputKey = TaskKey (projPath paths) mn -- Synchronous, like the full write: completion implies -- the refreshed rows are committed. A write failure is @@ -4001,9 +4155,16 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do (ccShouldWriteFrontOutput callbacks) outputKey FrontOutputTydb $ - InterfaceFiles.updateImplRefresh tyFile moduleImplHash updatedDepModules updatedNameHashes) + InterfaceFiles.updateImplRefresh tyFile refreshInput + InterfaceFiles.ImplRefreshOutput + { InterfaceFiles.iroImplementationHash = moduleImplHash + , InterfaceFiles.iroModuleHashInfo = updatedModuleHash + , InterfaceFiles.iroDependencies = updatedDepModules + , InterfaceFiles.iroNameHashes = updatedNameHashes + }) case res of Left err | isJust (fromException err :: Maybe SomeAsyncException) -> throwIO err + | InterfaceFiles.isImplRefreshStale err -> throwIO err | otherwise -> return (Just (tydbWriteDiagnostics mn err)) Right () -> return Nothing startOutputJobs = @@ -4015,9 +4176,14 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do FrontOutputTydbCopy (copyTydbInterface optsT paths mn) else return [] - deferredBackJob0 = dbpDeferredBackJob (isDbpBlocked key) moduleHasNotImpl optsT paths mn moduleImplHash (length updatedNameHashes) - case deferredBackJob0 of - Just _ -> do + backPassNeeded0 = shouldRunBackPass (isDbpBlocked key) + (Data.Set.member key requestedTasks) optsT roots + deferredBackJob0 + | backPassNeeded0 = selectiveDeferredBackJob + (isDbpBlocked key) moduleHasNotImpl optsT paths mn + | otherwise = Nothing + if not backPassNeeded0 || isJust deferredBackJob0 + then do ifaceRes <- readIfaceFromTy paths mn "" (Just storedPubHash) case ifaceRes of Left diags -> return (key, Left diags) @@ -4029,17 +4195,18 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do outputJobs <- startOutputJobs rememberFrontOutputJobList frontOutputRef outputJobs let deferredBackJob = deferredBackJob0 - fr = (mkFrontResult imps ifaceTE mdocI storedPubH moduleImplHash (publicNameHashes updatedNameHashes) updatedNameHashes Nothing deferredBackJob) + fr = (mkFrontResult imps ifaceTE mdocI storedPubH moduleImplHash (publicNameHashes updatedNameHashes) Nothing deferredBackJob) { frOutputJobs = outputJobs , frModuleInfo = mModuleInfo } cacheFrontResult fr - Nothing -> do + else do tyRes <- readTyFile case tyRes of Left diags -> return (key, Left diags) - Right (_ms, nmod, tmod, _sourceMeta, _moduleSrcBytesHash, modulePubHash, _moduleImplHash, _imps, _depModules, _nameHashes, _roots, _tests, mdoc) -> do - snap <- Source.readSource sp actFile + Right (_ms, nmod, tmod, _sourceMeta, moduleSrcBytesHash, modulePubHash, _moduleImplHash, _imps, _depModules, _nameHashes, _roots, _tests, mdoc) -> do + snap <- readMatchingSource + sp mn moduleSrcBytesHash actFile envRes <- (try :: IO Acton.Env.Env0 -> IO (Either SomeException Acton.Env.Env0)) $ Acton.Env.mkEnv (searchPath paths) envSnap tmod case envRes of @@ -4055,8 +4222,11 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do rememberFrontOutputJobList frontOutputRef outputJobs let I.NModule imps ifaceFull _mdoc = nmod ifaceTE = publicIfaceTE ifaceFull - backJob = Just (mkBackJob env1 tmod (Source.ssText snap) moduleImplHash) - fr = (mkFrontResult imps ifaceTE mdoc modulePubHash moduleImplHash (publicNameHashes updatedNameHashes) updatedNameHashes backJob Nothing) + codegenHash = Hashing.wholeCodegenHash + (not $ C.dbg_no_lines optsT) + moduleImplHash moduleSrcBytesHash + backJob = Just (mkBackJob env1 tmod (Source.ssText snap) codegenHash) + fr = (mkFrontResult imps ifaceTE mdoc modulePubHash moduleImplHash (publicNameHashes updatedNameHashes) backJob Nothing) { frOutputJobs = outputJobs } cacheFrontResult fr _ -> rerunFront @@ -4069,19 +4239,27 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do tyRes <- readTyFile case tyRes of Left diags -> return (key, Left diags) - Right (_ms, nmod, tmod, _sourceMeta, _moduleSrcBytesHash, modulePubHash, moduleImplHashStored, _imps, _depModules, nameHashes, _roots, _tests, mdoc) -> do - snap <- Source.readSource sp actFile + Right (_ms, nmod, tmod, _sourceMeta, moduleSrcBytesHash, modulePubHash, moduleImplHashStored, _imps, _depModules, nameHashes, roots, _tests, mdoc) -> do + snap <- readMatchingSource + sp mn moduleSrcBytesHash actFile env1 <- Acton.Env.mkEnv (searchPath paths) envSnap tmod - interestDeps <- cachedInterestDeps let I.NModule imps ifaceFull _mdoc = nmod ifaceTE = publicIfaceTE ifaceFull - deferredBackJob = dbpDeferredBackJob (isDbpBlocked key) (A.hasNotImpl (A.mbody tmod)) optsT paths mn moduleImplHashStored (length nameHashes) + backPassNeeded0 = shouldRunBackPass (isDbpBlocked key) + (Data.Set.member key requestedTasks) optsT roots + deferredBackJob + | backPassNeeded0 = selectiveDeferredBackJob + (isDbpBlocked key) (A.hasNotImpl (A.mbody tmod)) optsT paths mn + | otherwise = Nothing backJob = case deferredBackJob of Just _ -> Nothing - Nothing -> Just (mkBackJob env1 tmod (Source.ssText snap) moduleImplHashStored) - fr = (mkFrontResult imps ifaceTE mdoc modulePubHash moduleImplHashStored (publicNameHashes nameHashes) nameHashes backJob deferredBackJob) - { frInterestDeps = interestDeps } + Nothing | backPassNeeded0 -> Just (mkBackJob env1 tmod (Source.ssText snap) + (Hashing.wholeCodegenHash + (not $ C.dbg_no_lines optsT) + moduleImplHashStored moduleSrcBytesHash)) + Nothing -> Nothing + fr = mkFrontResult imps ifaceTE mdoc modulePubHash moduleImplHashStored (publicNameHashes nameHashes) backJob deferredBackJob cacheFrontResult fr runReuse = do --traceM ("\n## runReuse " ++ prstr mn ++ "\n") @@ -4097,11 +4275,8 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do TyTask{ tyNameHashes = nhs } -> nhs _ -> [] cachedNameHashes = publicNameHashes cachedFullNameHashes - interestDeps <- cachedInterestDeps - let fr = (mkFrontResult imps ifaceTE mdoc ih implH cachedNameHashes cachedFullNameHashes Nothing cachedDeferredBackJob) - { frModuleInfo = mModuleInfo - , frInterestDeps = interestDeps - } + let fr = (mkFrontResult imps ifaceTE mdoc ih implH cachedNameHashes Nothing cachedDeferredBackJob) + { frModuleInfo = mModuleInfo } cacheFrontResult fr case () of _ | needFront -> runFront @@ -4199,9 +4374,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do -> M.Map TaskKey B.ByteString -> M.Map TaskKey (M.Map A.Name InterfaceFiles.NameHashInfo) -> M.Map TaskKey CompileTask - -> InterestMap - -> Data.Set.Set TaskKey - -> M.Map TaskKey (DeferredBackJob, Data.Set.Set TaskKey) + -> M.Map TaskKey DeferredBackJob -> M.Map StageKey Int -> Data.Set.Set StageKey -> Acton.Env.Env0 @@ -4209,20 +4382,22 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do -> Int -> M.Map TaskKey Integer -> IO (Either CompileFailure (Acton.Env.Env0, Bool)) - loop frontOutputRef runningRef rdy running res implRes nameRes parsedTasks interestMap frontDone deferredBacks ind pend envAcc hadErrors maxPar cw = do + loop frontOutputRef runningRef rdy running res implRes nameRes parsedTasks deferredBacks ind pend envAcc hadErrors maxPar cw = do (rdy1, running1) <- mask_ $ do res@(rdy1', running1') <- scheduleMore (maxPar - length running) rdy running frontOutputRef res implRes nameRes parsedTasks envAcc cw writeIORef runningRef (map fst running1') return res if null running1 && null rdy1 then if Data.Set.null pend - then do - flushRes <- flushReadyDeferredBacks envAcc interestMap frontDone deferredBacks - case flushRes of - Left err -> return (Left err) - Right deferredBacks' -> do - writeIORef runningRef [] - return (Right (envAcc, hadErrors || not (M.null deferredBacks'))) + then if hadErrors + then return (Right (envAcc, True)) + else do + flushRes <- flushDeferredBacks deferredBacks + case flushRes of + Left err -> return (Left err) + Right () -> do + writeIORef runningRef [] + return (Right (envAcc, False)) else return (Right (envAcc, True)) else do (doneA, (stageDone, outcome)) <- waitAny $ map fst running1 @@ -4249,7 +4424,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do rdy2 = filter (`Data.Set.notMember` blockedStages) rdy1 dropKeys = keyDone : Data.Set.toList blockedMods parsedTasks2 = foldl' (flip M.delete) parsedTasks dropKeys - loop frontOutputRef runningRef rdy2 running3 res implRes nameRes parsedTasks2 interestMap frontDone deferredBacks ind pend2 envAcc True maxPar cw + loop frontOutputRef runningRef rdy2 running3 res implRes nameRes parsedTasks2 deferredBacks ind pend2 envAcc True maxPar cw Right success -> do let pend2 = Data.Set.delete stageDone pend ind2 = case M.lookup stageDone stageRevMap of @@ -4266,7 +4441,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do StageParsed parsed mParseTime -> do ccOnParseDone callbacks tDone optsDone mParseTime let parsedTasks2 = M.insert keyDone parsed parsedTasks - loop frontOutputRef runningRef rdy2 running2 res implRes nameRes parsedTasks2 interestMap frontDone deferredBacks ind2 pend2 envAcc hadErrors maxPar cw + loop frontOutputRef runningRef rdy2 running2 res implRes nameRes parsedTasks2 deferredBacks ind2 pend2 envAcc hadErrors maxPar cw StageFronted fr -> do ccOnFrontDone callbacks tDone optsDone ccOnFrontResult callbacks tDone optsDone fr @@ -4276,17 +4451,11 @@ compileTasks sp gopts opts rootPaths rootProj tasks dbpBlocked callbacks = do nameRes2 = M.insert keyDone (nameHashMapFromList (frNameHashes fr)) nameRes parsedTasks2 = M.delete keyDone parsedTasks envAcc' = Acton.Env.addModuleInfo (tkMod keyDone) (frontResultModuleInfo (tkMod keyDone) fr) envAcc - interestMap2 = addInterestDeps (frInterestDeps fr) interestMap - frontDone2 = Data.Set.insert keyDone frontDone deferredBacks1 = case frDeferredBackJob fr of Nothing -> deferredBacks - Just dbj -> M.insert keyDone (dbj, dependentClosure keyDone) deferredBacks - flushRes <- flushReadyDeferredBacks envAcc' interestMap2 frontDone2 deferredBacks1 - case flushRes of - Left err -> return (Left err) - Right deferredBacks2 -> - loop frontOutputRef runningRef rdy2 running2 res2 implRes2 nameRes2 parsedTasks2 interestMap2 frontDone2 deferredBacks2 ind2 pend2 envAcc' hadErrors maxPar cw + Just dbj -> M.insert keyDone dbj deferredBacks + loop frontOutputRef runningRef rdy2 running2 res2 implRes2 nameRes2 parsedTasks2 deferredBacks1 ind2 pend2 envAcc' hadErrors maxPar cw -- | Execute back-pass jobs in parallel while keeping output order stable. @@ -4316,7 +4485,9 @@ runBackJobs gopts maxPar onStart onDone jobs = do new <- forM toStart $ \(ix, job) -> async $ do onStart job - (res, _timing) <- runBackPasses gopts (bjOpts job) (bjPaths job) (bjInput job) (return True) + (res, _timing) <- runBackPasses + gopts (bjOpts job) (bjPaths job) (bjInput job) + (\action -> action >> return True) (\_ -> return ()) return (ix, job, res) let running' = running ++ new writeIORef runningRef running' diff --git a/compiler/lsp-server/Main.hs b/compiler/lsp-server/Main.hs index fe7b07701..9bebc56ad 100644 --- a/compiler/lsp-server/Main.hs +++ b/compiler/lsp-server/Main.hs @@ -37,6 +37,7 @@ import qualified Acton.Compile as Compile import qualified Acton.CommandLineParser as C import qualified Acton.Completion as Completion import qualified Acton.Env as Env +import qualified Acton.Hashing as Hashing import qualified Acton.SourceProvider as Source import qualified Acton.Syntax as S @@ -336,22 +337,25 @@ watchProjectShape rootProj watchedRoot = prepareLspCompilePlan :: Source.SourceProvider -> C.GlobalOptions - -> C.CompileOptions + -> Compile.CompileContext -> FilePath + -> Maybe [FilePath] -> LspM () (Either String (PlanOrigin, Compile.CompilePlan)) -prepareLspCompilePlan sp gopts opts path = do +prepareLspCompilePlan sp gopts ctx path changedPaths = do planE <- liftIO ((try $ do - ctx <- Compile.prepareCompileContext opts [path] path' <- Compile.normalizePathSafe path - mcache <- HM.lookup (Compile.ccRootProj ctx) <$> readIORef projectBuildCachesRef - case mcache of - Just cache - | Compile.ccBuildStamp (cachedCompileContext cache) == Compile.ccBuildStamp ctx -> do - mplan <- compilePlanFromCache ctx path' cache - case mplan of - Just plan -> return (PlanFromCache, plan) - Nothing -> freshPlan - _ -> freshPlan + case changedPaths of + Just _ -> do + mcache <- HM.lookup (Compile.ccRootProj ctx) <$> readIORef projectBuildCachesRef + case mcache of + Just cache + | Compile.ccBuildStamp (cachedCompileContext cache) == Compile.ccBuildStamp ctx -> do + mplan <- compilePlanFromCache ctx path' cache + case mplan of + Just plan -> return (PlanFromCache, plan) + Nothing -> freshPlan + _ -> freshPlan + Nothing -> freshPlan ) :: IO (Either SomeException (PlanOrigin, Compile.CompilePlan))) case planE of Left err -> @@ -361,7 +365,8 @@ prepareLspCompilePlan sp gopts opts path = do Right plan -> return (Right plan) where freshPlan = do - plan <- Compile.prepareCompilePlan sp gopts compileScheduler opts [path] False (Just [path]) + plan <- Compile.prepareCompilePlanFromContext + sp gopts ctx [path] False changedPaths cacheCompilePlan plan return (PlanFromDiscovery, plan) @@ -379,6 +384,17 @@ compilePlanFromCache ctx changedPath cache = do dbpBlocked [changedPath] let rootProj = Compile.ccRootProj ctx + rootTaskKeys = Data.Set.fromList + [ Compile.gtKey t + | t <- neededTasks + , Compile.tkProj (Compile.gtKey t) == rootProj + ] + requestedTasks = Data.Set.fromList + [ Compile.gtKey t + | t <- neededTasks + , let key = Compile.gtKey t + , Compile.srcFile (Compile.gtPaths t) (Compile.tkMod key) == changedPath + ] rootTasks = [ Compile.gtTask t | t <- neededTasks @@ -399,6 +415,8 @@ compilePlanFromCache ctx changedPath cache = do , Compile.cpNeededTasks = neededTasks , Compile.cpDbpBlocked = dbpBlocked , Compile.cpRootTasks = rootTasks + , Compile.cpRootTaskKeys = rootTaskKeys + , Compile.cpRequestedTasks = requestedTasks , Compile.cpRootPins = cachedRootPins cache , Compile.cpIncremental = True , Compile.cpAllowPrune = False @@ -706,33 +724,42 @@ runCompilePlanWithHooks gen rootProj path sp gopts opts progress = do compileRes <- liftIO $ Compile.withProjectLock rootProj $ do - planE <- runLspT env $ - prepareLspCompilePlan sp gopts opts path - case planE of - Left msg -> - return (Left msg) - Right (origin, plan) -> do - progressFor $ - case origin of - PlanFromCache -> "Acton cached project ready" - PlanFromDiscovery -> "Acton compile plan ready" - runRes <- Compile.runCompilePlan sp gopts plan compileScheduler gen hooks - case runRes of - Left err -> - return (Left (Compile.compileFailureMessage err)) - Right (envAcc, _) -> do - rememberCompletionStates gen plan envAcc - progressFor "Completion ready" - let opts' = Compile.ccOpts (Compile.cpContext plan) - backFailure <- - if C.only_build opts' - then return Nothing - else Compile.backQueueWait (Compile.csBackQueue compileScheduler) gen - case backFailure of - Just failure -> - return (Left (Compile.backPassFailureMessage failure)) - Nothing -> - return (Right ()) + ctx <- Compile.prepareCompileContext opts [path] + specChanged <- Compile.checkBuildSpecChange + compileScheduler (Compile.ccBuildStamp ctx) + when specChanged $ + Compile.fetchDependencies gopts + (Compile.ccPathsRoot ctx) (Compile.ccDepOverrides ctx) + lockPaths <- Compile.compileOutputLockPaths gopts ctx + Compile.withCompileOutputLockPaths lockPaths $ do + let changedPaths = if specChanged then Nothing else Just [path] + planE <- runLspT env $ + prepareLspCompilePlan sp gopts ctx path changedPaths + case planE of + Left msg -> + return (Left msg) + Right (origin, plan) -> do + progressFor $ + case origin of + PlanFromCache -> "Acton cached project ready" + PlanFromDiscovery -> "Acton compile plan ready" + runRes <- Compile.runCompilePlan sp gopts plan compileScheduler gen hooks + case runRes of + Left err -> + return (Left (Compile.compileFailureMessage err)) + Right (envAcc, _) -> do + rememberCompletionStates gen plan envAcc + progressFor "Completion ready" + let opts' = Compile.ccOpts (Compile.cpContext plan) + backFailure <- + if C.only_build opts' + then return Nothing + else Compile.backQueueWait (Compile.csBackQueue compileScheduler) gen + case backFailure of + Just failure -> + return (Left (Compile.backPassFailureMessage failure)) + Nothing -> + return (Right ()) case compileRes of Left msg -> notifyCompileError gen msg >> return False Right () -> return True @@ -1089,7 +1116,10 @@ handlers = -- | Start the Acton LSP server with the configured handlers. main :: IO Int -main = +main = do + -- Force the executable identity before background compilation starts. + -- Hashing memoizes the result for all later code-generation keys. + _ <- evaluate Hashing.codegenIdentity runServer serverDef `finally` releaseBackgroundCompilerLocks where serverDef = From 047360f18f03572fc96b212124b5698507e1e9b9 Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Tue, 18 Aug 2026 17:32:44 +0200 Subject: [PATCH 8/9] Test selective compilation Unit tests cover row round-trips, exact-key reads, worklist closure and projection assembly. End-to-end projects compile and run through deferred scheduling, generated C, incremental invalidation, inheritance, native providers, output locking and consumer-specific provider output, including aliases, optional truth conversion, inherited property layout, module initialization, declaration-only types and rootless requests. The important dce2 cases are carried over. --- compiler/acton/test.hs | 963 +++++++++++++++- compiler/acton/test_incremental.hs | 208 +++- compiler/lib/test/ActonSpec.hs | 1634 ++++++++++++++++++++++++++-- test/core_lang_auto/get_attr.act | 17 + 4 files changed, 2638 insertions(+), 184 deletions(-) diff --git a/compiler/acton/test.hs b/compiler/acton/test.hs index 13a7031ad..4ec9cc758 100644 --- a/compiler/acton/test.hs +++ b/compiler/acton/test.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} import Control.Monad -import Data.Char (isAlphaNum, isSpace) +import Data.Char (isAlphaNum, isHexDigit, isSpace) import Data.List import Data.List.Split import Data.Maybe (catMaybes) @@ -382,6 +382,400 @@ compilerTests = (returnCode, cmdOut, cmdErr) <- readCreateProcessWithExitCode (shell $ "rm -rf ../../test/compiler/test_deps/deps/a/out") "" runActon "build" ExitSuccess False "../../test/compiler/test_deps/" + , testCase "dce closure keeps qualified member dependencies exact" $ do + withSystemTempDirectory "acton-dce-baseline" $ \proj -> do + actonExe <- canonicalizePath "../../dist/bin/acton" + let name = "dce_baseline" + fp = Fingerprint.formatFingerprint + (Fingerprint.updateFingerprintPrefix + (Fingerprint.fingerprintPrefixForName name) 1) + srcDir = proj "src" + typesDir = proj "out" "types" "dce_baseline" + runBuild args = readCreateProcessWithExitCode (proc actonExe args){ cwd = Just proj } "" + assertOk label (code, out, err) = do + when (code /= ExitSuccess) $ + putStrLn ("\nERROR: " ++ label ++ "\nSTDOUT:\n" ++ out ++ "STDERR:\n" ++ err) + assertEqual label ExitSuccess code + return (out ++ err) + runSmall label expected = do + (code,out,err) <- readCreateProcessWithExitCode + (proc (proj "out" "bin" "small") []) "" + when (code /= ExitSuccess) $ + putStrLn ("\nERROR: " ++ label ++ "\nSTDOUT:\n" ++ out ++ "STDERR:\n" ++ err) + assertEqual label ExitSuccess code + assertEqual (label ++ " output") expected + (dropWhileEnd isSpace $ dropWhile isSpace out) + createDirectoryIfMissing True srcDir + writeFile (proj "Build.act") $ unlines + [ "name = \"" ++ name ++ "\"" + , "fingerprint = " ++ fp + , "" + ] + -- Apa.bepa is never called; its body is the only reference to + -- Jungle. + writeFile (srcDir "big.act") $ unlines + [ "class Jungle(object):" + , " def __init__(self):" + , " pass" + , " def roar(self) -> int:" + , " return 99" + , "" + , "class Apa(object):" + , " def __init__(self):" + , " pass" + , " def apa(self) -> int:" + , " return 1" + , " def bepa(self) -> int:" + , " j = Jungle()" + , " return j.roar()" + , "" + , "class Bepa(object):" + , " def __init__(self):" + , " pass" + , " def bepa(self) -> int:" + , " return 2" + ] + writeFile (srcDir "small.act") $ unlines + [ "import big" + , "" + , "actor main(env):" + , " a = big.Apa()" + , " b = big.Bepa()" + , " print(a.apa() + b.bepa())" + , " env.exit(0)" + ] + -- The call is recorded as (Bepa, bepa), so Apa.bepa is not kept. It + -- stubs out, and Jungle is never selected because only that body + -- references it. + log1 <- assertOk "dce qualified member build" =<< + runBuild ["build", "--verbose", "--color", "never"] + assertBool "qualified selection should select big" ("Selective back big:" `isInfixOf` log1) + bigC1 <- readFile (typesDir "big.c") + assertBool "qualified selection should omit Jungle" (not ("JungleG_new" `isInfixOf` bigC1)) + assertBool "qualified selection should keep the Apa.bepa slot" ("ApaG_methods.bepa" `isInfixOf` bigC1) + runSmall "qualified member selection runs" "3" + -- Drop the Bepa.bepa call too: bepa leaves the CN entirely; the + -- closure stays at 2 (both classes are constructed) and Bepa.bepa + -- now stubs as well. + writeFile (srcDir "small.act") $ unlines + [ "import big" + , "" + , "actor main(env):" + , " a = big.Apa()" + , " b = big.Bepa()" + , " print(a.apa())" + , " env.exit(0)" + ] + log2 <- assertOk "dce baseline pruned build" =<< + runBuild ["build", "--verbose", "--color", "never"] + assertBool "pruned state should select big" ("Selective back big:" `isInfixOf` log2) + bigC2 <- readFile (typesDir "big.c") + assertBool "pruned state should omit Jungle" (not ("JungleG_new" `isInfixOf` bigC2)) + assertBool "pruned state should keep the bepa slot" ("ApaG_methods.bepa" `isInfixOf` bigC2) + runSmall "pruned state runs" "1" + -- DISPATCH, override direction: poke takes an Apa and calls x.apa(); + -- the runtime object is a Cepa, whose apa OVERRIDE is the only + -- reference to Jungle. The (Apa, apa) entry must reach Cepa.apa + -- (Apa is an ancestor of Cepa), or the run would hit the stub. + writeFile (srcDir "big.act") $ unlines + [ "class Jungle(object):" + , " def __init__(self):" + , " pass" + , " def roar(self) -> int:" + , " return 99" + , "" + , "class Apa(object):" + , " def __init__(self):" + , " pass" + , " def apa(self) -> int:" + , " return 1" + , " def bepa(self) -> int:" + , " return 3" + , "" + , "class Cepa(Apa):" + , " def __init__(self):" + , " pass" + , " def apa(self) -> int:" + , " j = Jungle()" + , " return j.roar()" + ] + writeFile (srcDir "small.act") $ unlines + [ "import big" + , "" + , "def poke(x: big.Apa) -> int:" + , " return x.apa()" + , "" + , "actor main(env):" + , " c = big.Cepa()" + , " print(poke(c))" + , " env.exit(0)" + ] + log3 <- assertOk "dce dispatch override build" =<< + runBuild ["build", "--verbose", "--color", "never"] + bigC3 <- readFile (typesDir "big.c") + assertBool "override dispatch should keep Cepa.apa (and Jungle)" ("JungleG_new" `isInfixOf` bigC3) + runSmall "override dispatch runs selected implementation" "99" + -- DISPATCH, inherited direction: the call is typed through the + -- SUBCLASS (Cepa.bepa) but the implementation lives on the base + -- (Apa.bepa, never overridden). The (Cepa, bepa) entry must reach + -- Apa.bepa (Apa is an ancestor of the receiver class). + writeFile (srcDir "small.act") $ unlines + [ "import big" + , "" + , "actor main(env):" + , " c = big.Cepa()" + , " print(c.bepa())" + , " env.exit(0)" + ] + log4 <- assertOk "dce dispatch inherited build" =<< + runBuild ["build", "--verbose", "--color", "never"] + bigC4 <- readFile (typesDir "big.c") + assertBool "inherited dispatch should keep the bepa slot" ("ApaG_methods.bepa" `isInfixOf` bigC4) + runSmall "inherited dispatch runs base implementation" "3" + -- DISPATCH over PRIVATE classes (yang's _Builder/_PosBuilder + -- pattern): the persisted shape lineage must preserve private + -- ancestors or overrides in a private hierarchy are wrongly + -- stubbed and the program raises. + writeFile (srcDir "big.act") $ unlines + [ "class _Base(object):" + , " def __init__(self):" + , " pass" + , " def part(self) -> int:" + , " return 0" + , "" + , "class _P(_Base):" + , " def __init__(self):" + , " pass" + , " def part(self) -> int:" + , " return 1" + , "" + , "class _N(_Base):" + , " def __init__(self):" + , " pass" + , " def part(self) -> int:" + , " return 2" + , "" + , "def build(neg: bool) -> int:" + , " b: _Base = _N() if neg else _P()" + , " return b.part()" + ] + writeFile (srcDir "small.act") $ unlines + [ "import big" + , "" + , "actor main(env):" + , " print(big.build(True) + big.build(False))" + , " env.exit(0)" + ] + log5 <- assertOk "dce dispatch private-class build" =<< + runBuild ["build", "--verbose", "--color", "never"] + bigC5 <- readFile (typesDir "big.c") + assertBool "private-class dispatch should keep the hierarchy" ("bigQ__N" `isInfixOf` bigC5) + runSmall "private-class dispatch runs every selected override" "3" + -- REFRESH PATH: calls made inside a consumer CLASS METHOD live only + -- in its member rows. When the provider changes and the consumer is + -- unchanged, the consumer takes the impl-refresh path (rows re-read + -- from disk); its call-set contribution must come from the persisted + -- union or the provider prunes methods the consumer still invokes. + writeFile (srcDir "big.act") $ unlines + [ "class Bepa(object):" + , " def __init__(self):" + , " pass" + , " def bepa(self) -> int:" + , " return 2" + ] + writeFile (srcDir "small.act") $ unlines + [ "import big" + , "" + , "class Wrapper(object):" + , " def __init__(self):" + , " pass" + , " def wrap(self) -> int:" + , " b = big.Bepa()" + , " return b.bepa()" + , "" + , "actor main(env):" + , " w = Wrapper()" + , " print(w.wrap())" + , " env.exit(0)" + ] + _ <- assertOk "dce refresh baseline build" =<< + runBuild ["build", "--verbose", "--color", "never"] + runSmall "refresh baseline runs" "2" + -- Change ONLY the provider: the consumer re-derives its front result + -- from disk rows. + writeFile (srcDir "big.act") $ unlines + [ "class Bepa(object):" + , " def __init__(self):" + , " pass" + , " def bepa(self) -> int:" + , " return 3" + ] + _ <- assertOk "dce refresh provider-change build" =<< + runBuild ["build", "--verbose", "--color", "never"] + bigC6 <- readFile (typesDir "big.c") + assertBool "provider change must retain Bepa" ("bigQ_Bepa" `isInfixOf` bigC6) + runSmall "provider refresh preserves consumer member dependencies" "3" + + , testCase "selective constructor fields and actor initializers" $ do + withSystemTempDirectory "acton-selective-init" $ \proj -> do + actonExe <- canonicalizePath "../../dist/bin/acton" + let name = "selective_init" + fp = Fingerprint.formatFingerprint + (Fingerprint.updateFingerprintPrefix + (Fingerprint.fingerprintPrefixForName name) 1) + srcDir = proj "src" + providerC = proj "out" "types" name "provider.c" + providerH = proj "out" "types" name "provider.h" + assertSelection generated header = do + assertBool "selected field initializer should keep its dependency" + ("used_value" `isInfixOf` generated) + assertBool "unselected field initializer should omit its dependency" + (not ("unused_value" `isInfixOf` generated)) + assertBool "selected conditional initializer should keep its guard" + ("choose_value" `isInfixOf` generated) + assertBool "selected actor initializer should keep its dependency" + ("actor_value" `isInfixOf` generated) + assertBool "unselected actor initializer should omit its dependency" + (not ("unused_actor_value" `isInfixOf` generated)) + assertBool "imperative constructor rest should remain selected" + ("rest_marker" `isInfixOf` generated) + assertBool "selected class field should remain in the object layout" + (" int64_t used;" `isInfixOf` header) + assertBool "unselected class field should be absent from the object layout" + (not $ " int64_t unused;" `isInfixOf` header) + assertBool "selected actor field should remain in the object layout" + (" int64_t MAGIC;" `isInfixOf` header) + assertBool "unselected actor field should be absent from the object layout" + (not $ " int64_t UNUSED;" `isInfixOf` header) + createDirectoryIfMissing True srcDir + writeFile (proj "Build.act") $ unlines + [ "name = \"" ++ name ++ "\"" + , "fingerprint = " ++ fp + , "" + ] + writeFile (srcDir "provider.act") $ unlines + [ "def used_value() -> int:" + , " return 40" + , "" + , "def unused_value() -> int:" + , " return 99" + , "" + , "def choose_value() -> bool:" + , " return True" + , "" + , "def actor_value() -> int:" + , " return 2" + , "" + , "def unused_actor_value() -> int:" + , " return 100" + , "" + , "def rest_marker() -> None:" + , " pass" + , "" + , "class Payload(object):" + , " def __init__(self):" + , " if choose_value():" + , " self.used = used_value()" + , " self.unused = unused_value()" + , " else:" + , " self.used = used_value()" + , " self.unused = unused_value()" + , " rest_marker()" + , "" + , " def total(self) -> int:" + , " return self.used" + , "" + , "actor Constants():" + , " MAGIC = actor_value()" + , " UNUSED = unused_actor_value()" + , "" + , " def magic() -> int:" + , " return MAGIC" + ] + writeFile (srcDir "main.act") $ unlines + [ "import provider" + , "" + , "actor main(env):" + , " payload = provider.Payload()" + , " constants = provider.Constants()" + , " print(payload.total() + constants.magic())" + , " env.exit(0)" + ] + (buildCode,buildOut,buildErr) <- readCreateProcessWithExitCode + (proc actonExe ["build", "--verbose", "--color", "never"]){ cwd = Just proj } "" + when (buildCode /= ExitSuccess) $ + putStrLn ("\nERROR: selective initializer build\nSTDOUT:\n" ++ buildOut ++ "STDERR:\n" ++ buildErr) + assertEqual "selective initializer build" ExitSuccess buildCode + generated <- readFile providerC + header <- readFile providerH + assertSelection generated header + removeFile providerC + removeFile providerH + (cachedCode,cachedOut,cachedErr) <- readCreateProcessWithExitCode + (proc actonExe ["build", "--verbose", "--color", "never"]){ cwd = Just proj } "" + when (cachedCode /= ExitSuccess) $ + putStrLn ("\nERROR: cached selective initializer build\nSTDOUT:\n" ++ cachedOut ++ "STDERR:\n" ++ cachedErr) + assertEqual "cached selective initializer build" ExitSuccess cachedCode + let cachedLog = cachedOut ++ cachedErr + assertBool "cached initializer consumer should reuse its TYDB" + ("Fresh main: using cached .tydb" `isInfixOf` cachedLog) + assertBool "cached initializer build should reconstruct its provider" + ("Selective back provider:" `isInfixOf` cachedLog) + cachedGenerated <- readFile providerC + cachedHeader <- readFile providerH + assertSelection cachedGenerated cachedHeader + (runCode,runOut,runErr) <- readCreateProcessWithExitCode + (proc (proj "out" "bin" "main") []) "" + assertEqual ("selective initializer binary should run: " ++ runErr) ExitSuccess runCode + assertEqual "selective initializer binary should print 42" "42" + (dropWhileEnd isSpace $ dropWhile isSpace runOut) + + , testCase "selective imports preserve module initialization dependencies" $ do + withSystemTempDirectory "acton-selective-import-init" $ \proj -> do + actonExe <- canonicalizePath "../../dist/bin/acton" + let name = "selective_import_init" + fp = Fingerprint.formatFingerprint + (Fingerprint.updateFingerprintPrefix + (Fingerprint.fingerprintPrefixForName name) 1) + srcDir = proj "src" + consumerC = proj "out" "types" name "consumer.c" + createDirectoryIfMissing True srcDir + writeFile (proj "Build.act") $ unlines + [ "name = \"" ++ name ++ "\"" + , "fingerprint = " ++ fp + , "" + ] + writeFile (srcDir "provider.act") $ unlines + [ "marker = 1" ] + writeFile (srcDir "consumer.act") $ unlines + [ "from provider import marker" + , "" + , "def answer() -> int:" + , " return 42" + ] + writeFile (srcDir "main.act") $ unlines + [ "import consumer" + , "" + , "actor main(env):" + , " print(consumer.answer())" + , " env.exit(0)" + ] + (buildCode,buildOut,buildErr) <- readCreateProcessWithExitCode + (proc actonExe ["build", "--verbose", "--color", "never"]){ cwd = Just proj } "" + when (buildCode /= ExitSuccess) $ + putStrLn ("\nERROR: selective import initializer build\nSTDOUT:\n" ++ + buildOut ++ "STDERR:\n" ++ buildErr) + assertEqual "selective import initializer build" ExitSuccess buildCode + generated <- readFile consumerC + assertBool "selective consumer should initialize its imported provider" + ("providerQ___init__();" `isInfixOf` generated) + (runCode,runOut,runErr) <- readCreateProcessWithExitCode + (proc (proj "out" "bin" "main") []) "" + assertEqual ("selective import initializer binary should run: " ++ runErr) + ExitSuccess runCode + assertEqual "selective import initializer binary output" "42" + (dropWhileEnd isSpace $ dropWhile isSpace runOut) + , testCase "dbp selects provider subset and cached header interest" $ do withSystemTempDirectory "acton-dbp" $ \proj -> do actonExe <- canonicalizePath "../../dist/bin/acton" @@ -403,46 +797,110 @@ compilerTests = assertBool label (code /= ExitSuccess) return (out ++ err) removeIfExists path = removeFile path `catch` \(_ :: IOException) -> return () + runMain label expected = do + (code,out,err) <- readCreateProcessWithExitCode + (proc (proj "out" "bin" "main") []) "" + when (code /= ExitSuccess) $ + putStrLn ("\nERROR: " ++ label ++ "\nSTDOUT:\n" ++ out ++ "STDERR:\n" ++ err) + assertEqual label ExitSuccess code + assertEqual (label ++ " output") expected + (dropWhileEnd isSpace $ dropWhile isSpace out) createDirectoryIfMissing True srcDir writeFile (proj "Build.act") $ unlines [ "name = \"" ++ name ++ "\"" , "fingerprint = " ++ fp , "" ] - writeFile (srcDir "provider.act") $ unlines - [ "protocol Renderable:" - , " val : () -> int" - , "" - , "class Box(value):" - , " def __init__(self, x: int):" - , " self.x = x" - , "" - , " def get(self) -> int:" - , " return self.x" - , "" - , "extension Box(Renderable):" - , " def val(self) -> int:" - , " return self.get()" - , "" - , "def make_box() -> Box:" - , " return Box(42)" - , "" - , "def render_box() -> int:" - , " return Box(7).val()" + writeFile (srcDir "sibling.act") $ unlines + [ "protocol BaseSlot:" + , " same : () -> int" , "" - , "def unused_0() -> int:" - , " return 0" - , "" - , "def unused_1() -> int:" - , " return 1" + , "protocol ProviderSlot(BaseSlot):" + , " pass" , "" - , "class Container:" + , "class SiblingHost(object):" , " def __init__(self):" , " pass" , "" - , "def local_container_name(x: object) -> bool:" - , " return isinstance(x, Container)" + , "extension SiblingHost(ProviderSlot):" + , " def same(self) -> int:" + , " return 73" ] + let providerSource = unlines + [ "import sibling" + , "" + , "protocol Renderable:" + , " val : () -> int" + , "" + , "class SignatureOnly(object):" + , " def __init__(self):" + , " pass" + , "" + , "class Box(value):" + , " def __init__(self, x: int):" + , " self.x = x" + , "" + , " def get(self) -> int:" + , " return self.x" + , "" + , " def unused_typed(self, value: SignatureOnly) -> SignatureOnly:" + , " return value" + , "" + , "extension Box(Renderable):" + , " def val(self) -> int:" + , " return self.get()" + , "" + , "def make_box() -> Box:" + , " return Box(42)" + , "" + , "def render_box() -> int:" + , " return Box(7).val()" + , "" + , "protocol TargetSlot(sibling.BaseSlot):" + , " pass" + , "" + , "extension sibling.SiblingHost(TargetSlot):" + , " pass" + , "" + , "def invoke_sibling[T(TargetSlot)](value: T) -> int:" + , " return value.same()" + , "" + , "def run_sibling() -> int:" + , " return invoke_sibling(sibling.SiblingHost())" + , "" + , "def unused_0() -> int:" + , " return 0" + , "" + , "def unused_1() -> int:" + , " return 1" + , "" + , "class Container:" + , " def __init__(self):" + , " pass" + , "" + , "def local_container_name(x: object) -> bool:" + , " return isinstance(x, Container)" + , "" + , "class WorkBase(object):" + , " work : proc() -> int" + , "" + , "class _WorkHelper(object):" + , " def __init__(self):" + , " pass" + , " def val(self) -> int:" + , " return 42" + , "" + , "class WorkImpl(WorkBase):" + , " def __init__(self):" + , " pass" + , " proc def work(self) -> int:" + , " h = _WorkHelper()" + , " return h.val()" + , "" + , "def make_work() -> WorkImpl:" + , " return WorkImpl()" + ] + writeFile (srcDir "provider.act") providerSource writeFile (srcDir "main.act") $ unlines [ "import provider" , "" @@ -451,12 +909,68 @@ compilerTests = , " env.exit(0)" ] firstLog <- assertOk "initial dbp build" =<< - runBuild ["build", "--skip-build", "--verbose", "--color", "never"] - assertBool "initial build should report DBP selection" ("DBP provider: total names" `isInfixOf` firstLog) - assertBool "initial build should select a subset" ("selected closure" `isInfixOf` firstLog) + runBuild ["build", "--verbose", "--color", "never"] + assertBool "initial build should report selective provider back" + ("Selective back provider:" `isInfixOf` firstLog) + reachabilityLog <- assertOk "project reachability output" =<< + runBuild ["sig", "--reachability", "--color", "never"] + assertBool "project reachability should start with the report" + ("reachability\n" `isPrefixOf` reachabilityLog) + assertBool "project reachability should show the selected provider" + ("module dbp_fixture.provider" `isInfixOf` reachabilityLog) + assertBool "project reachability should show the selected entry point" + ("make_box [body]" `isInfixOf` reachabilityLog) + assertBool "project reachability should omit an unused provider definition" + (not $ "unused_1 [body]" `isInfixOf` reachabilityLog) + assertBool "project reachability should not include build progress" + (not $ "Compilation done" `isInfixOf` reachabilityLog) + storedReachability <- assertOk "stored reachability output" =<< + runBuild ["sig", "--reachability", "provider"] + assertBool "stored reachability should include unselected definitions" + ("name unused_1" `isInfixOf` storedReachability) + classReachability <- assertOk "stored class reachability output" =<< + runBuild ["sig", "--reachability", "provider.WorkImpl"] + assertBool "stored class reachability should show the requested class" + ("class WorkImpl" `isInfixOf` classReachability) providerC <- readFile (typesDir "provider.c") + providerH <- readFile (typesDir "provider.h") assertBool "selected provider C should include selected root" ("make_box" `isInfixOf` providerC) assertBool "selected provider C should omit unused definitions" (not ("unused_1" `isInfixOf` providerC)) + let signatureOnly = "dbp_fixtureQ_providerQ_SignatureOnly" + assertBool "stub signatures should forward-declare local types" + (("struct " ++ signatureOnly ++ ";") `isInfixOf` providerH) + assertBool "stub signatures should typedef local types" + (("typedef struct " ++ signatureOnly ++ " *" ++ signatureOnly ++ ";") `isInfixOf` providerH) + assertBool "declaration-only local types should not define an object layout" + (not $ ("struct " ++ signatureOnly ++ " {") `isInfixOf` providerH) + assertBool "declaration-only local types should not declare a constructor" + (not $ (signatureOnly ++ "G_new(") `isInfixOf` providerH) + assertBool "declaration-only local types should not emit a constructor" + (not $ (signatureOnly ++ "G_new(") `isInfixOf` providerC) + assertBool "declaration-only local types should not emit method bodies" + (not $ (signatureOnly ++ "D_") `isInfixOf` providerC) + assertBool "declaration-only local types should not emit a methods table" + (not $ (signatureOnly ++ "G_methods") `isInfixOf` providerC) + runMain "stub signature declaration links" "42" + let oldUnusedBody = "def unused_1() -> int:\n return 1" + newUnusedBody = "def unused_1() -> int:\n return 101" + updatedProviderSource = + intercalate newUnusedBody (splitOn oldUnusedBody providerSource) + assertBool "provider fixture should contain the unselected body" + (oldUnusedBody `isInfixOf` providerSource) + writeFile (srcDir "provider.act") updatedProviderSource + unselectedEditLog <- assertOk "unselected provider edit skips selective codegen" =<< + runBuild ["build", "--skip-build", "--verbose", "--color", "never"] + assertBool "unselected provider edit should rerun front passes" + ("Stale provider: source changed" `isInfixOf` unselectedEditLog) + assertBool "unchanged selection should keep provider codegen up to date" + (any (\line -> "Selective back provider:" `isInfixOf` line && + "generated code up to date" `isInfixOf` line) + (lines unselectedEditLog)) + assertEqual "unselected provider edit should preserve selected C output" + providerC =<< readFile (typesDir "provider.c") + assertEqual "unselected provider edit should preserve selected header output" + providerH =<< readFile (typesDir "provider.h") writeFile (srcDir "main.act") $ unlines [ "import provider" , "" @@ -466,7 +980,8 @@ compilerTests = ] changedConsumerLog <- assertOk "changed consumer updates dbp selection" =<< runBuild ["build", "--skip-build", "--verbose", "--color", "never"] - assertBool "changed consumer should rerun provider DBP" ("DBP provider: total names" `isInfixOf` changedConsumerLog) + assertBool "changed consumer should rerun provider back" + ("Selective back provider:" `isInfixOf` changedConsumerLog) assertBool "changed consumer should make DBP codegen stale" ("generated code out of date" `isInfixOf` changedConsumerLog) providerC1b <- readFile (typesDir "provider.c") assertBool "changed consumer C should include newly interested root" ("unused_0" `isInfixOf` providerC1b) @@ -480,14 +995,13 @@ compilerTests = secondLog <- assertOk "cached dbp build" =<< runBuild ["build", "--skip-build", "--verbose", "--color", "never"] assertBool "cached consumer should be reused" ("Fresh main: using cached .tydb" `isInfixOf` secondLog) - assertBool "cached build should collect provider interest from headers" ("interested names 1" `isInfixOf` secondLog) - assertBool "cached build should still select the dependency closure" ("selected closure" `isInfixOf` secondLog) + assertBool "cached build should reconstruct the selective provider" + ("Selective back provider:" `isInfixOf` secondLog) writeFile (srcDir "main.act") $ unlines [ "import provider" , "" , "actor main(env):" - , " f = provider.local_container_name" - , " print(\"ok\")" + , " print(provider.local_container_name(provider.WorkImpl()))" , " env.exit(0)" ] _thirdLog <- assertOk "dbp local name shadows builtin" =<< @@ -502,10 +1016,30 @@ compilerTests = , " env.exit(0)" ] fourthLog <- assertOk "dbp keeps extension" =<< - runBuild ["build", "--skip-build", "--verbose", "--color", "never"] - assertBool "extension selection should not fall back" (not ("fallback:" `isInfixOf` fourthLog)) + runBuild ["build", "--verbose", "--color", "never"] + assertBool "extension build should remain selective" + ("Selective back provider:" `isInfixOf` fourthLog) providerC3 <- readFile (typesDir "provider.c") assertBool "selected provider C should keep extension" ("providerQ_RenderableD_Box" `isInfixOf` providerC3) + runMain "selected extension runs" "7" + writeFile (srcDir "main.act") $ unlines + [ "import provider" + , "" + , "actor main(env):" + , " print(provider.run_sibling())" + , " env.exit(0)" + ] + siblingLog <- assertOk "dbp forwards an inherited slot through a sibling witness" =<< + runBuild ["build", "--verbose", "--color", "never"] + assertBool "sibling witness build should remain selective" + ("Selective back provider:" `isInfixOf` siblingLog) + providerCSibling <- readFile (typesDir "provider.c") + assertBool "selected target witness should emit its forwarding method" + ("TargetSlotD_SiblingHostD_dbp_fixtureD_siblingD_same" `isInfixOf` providerCSibling) + siblingC <- readFile (typesDir "sibling.c") + assertBool "selected sibling witness should retain the concrete slot" + ("ProviderSlotD_SiblingHostD_same" `isInfixOf` siblingC) + runMain "inherited slot forwards through sibling witness" "73" writeFile (srcDir "main.act") $ unlines [ "import provider" , "" @@ -514,27 +1048,64 @@ compilerTests = ] fifthLog <- assertOk "dbp empty interest" =<< runBuild ["build", "--skip-build", "--verbose", "--color", "never"] - assertBool "empty interest should not fall back" (not ("fallback:" `isInfixOf` fifthLog)) - assertBool "empty interest should be reported" ("interested names 0" `isInfixOf` fifthLog) - assertBool "empty interest should select empty closure" ("selected closure 0" `isInfixOf` fifthLog) + assertBool "empty interest should produce an empty provider projection" + ("Selective back provider: 0 tops, 0 members" `isInfixOf` fifthLog) providerC4 <- readFile (typesDir "provider.c") assertBool "empty provider C should omit provider definitions" (not ("make_box" `isInfixOf` providerC4)) + writeFile (srcDir "main.act") $ unlines + [ "import provider" + , "" + , "actor main(env):" + , " w = provider.make_work()" + , " print(\"ok\")" + , " env.exit(0)" + ] + _ <- assertOk "dbp stubs an uncalled abstract implementation" =<< + runBuild ["build", "--verbose", "--color", "never"] + providerCStub <- readFile (typesDir "provider.c") + assertBool "uncalled abstract implementation helper should remain pruned" + (not $ "providerQ__WorkHelper" `isInfixOf` providerCStub) + runMain "uncalled abstract implementation stub links" "ok" + writeFile (srcDir "main.act") $ unlines + [ "import provider" + , "" + , "proc def invoke(w: provider.WorkBase) -> int:" + , " return w.work()" + , "" + , "actor main(env):" + , " print(invoke(provider.make_work()))" + , " env.exit(0)" + ] + _ <- assertOk "dbp selects abstract implementation body dependencies" =<< + runBuild ["build", "--verbose", "--color", "never"] + providerCAbs <- readFile (typesDir "provider.c") + assertBool "selected implementation body should keep its helper" + ("providerQ__WorkHelper" `isInfixOf` providerCAbs) + runMain "abstract dispatch runs selected implementation" "42" removeIfExists (typesDir "main.c") removeIfExists (typesDir "main.h") removeIfExists (typesDir "main.root.c") sixthLog <- assertOk "dbp keeps executable root actor" =<< runBuild ["build", "--verbose", "--color", "never"] - assertBool "root module should report root seed" ("DBP main: total names" `isInfixOf` sixthLog) - assertBool "root module should count root name" ("root names 1" `isInfixOf` sixthLog) + assertBool "root module should report selective back" + ("Selective back main:" `isInfixOf` sixthLog) mainC <- readFile (typesDir "main.c") assertBool "selected main C should keep root actor" ("mainQ_main" `isInfixOf` mainC) seventhLog <- assertOk "no-dbp disables dbp" =<< runBuild ["build", "--skip-build", "--verbose", "--no-dbp", "--color", "never"] - assertBool "no-dbp should suppress provider DBP" (not ("DBP provider:" `isInfixOf` seventhLog)) + assertBool "no-dbp should suppress selective provider back" + (not ("Selective back provider:" `isInfixOf` seventhLog)) providerC5 <- readFile (typesDir "provider.c") assertBool "no-dbp provider C should include full module definitions" ("unused_1" `isInfixOf` providerC5) - - , testCase "dbp excludes explicit library boundary modules" $ do + dbLog <- assertOk "db mode keeps persistence providers whole" =<< + runBuild ["build", "--skip-build", "--verbose", "--db", "--color", "never"] + assertBool "db mode should suppress selective provider back" + (not $ "Selective back provider:" `isInfixOf` dbLog) + providerDbC <- readFile (typesDir "provider.c") + assertBool "db mode should preserve the full persistence schema" + ("unused_1" `isInfixOf` providerDbC) + + , testCase "dbp keeps library dependency projections consumer-specific" $ do withSystemTempDirectory "acton-dbp-library-boundary" $ \proj -> do actonExe <- canonicalizePath "../../dist/bin/acton" let name = "dbp_library_boundary" @@ -554,7 +1125,7 @@ compilerTests = [ "name = \"" ++ name ++ "\"" , "fingerprint = " ++ fp , "libraries = {" - , " \"foo\": (modules=[\"a\", \"b\"], linkage=\"static\")" + , " \"foo\": (modules=[\"a\", \"b\", \"d\"], linkage=\"static\")" , "}" ] writeFile (srcDir "a.act") $ unlines @@ -566,32 +1137,270 @@ compilerTests = ] writeFile (srcDir "b.act") $ unlines [ "import a" + , "import base" + , "import impl" + , "import proto" , "" , "def exposed() -> int:" - , " return a.used()" + , " return a.used() + Derived().inherited()" + , "" + , "def use_protocol[T(proto.Proto)](value: T) -> int:" + , " return value.val()" + , "" + , "def call_protocol() -> int:" + , " return use_protocol(impl.Concrete())" + , "" + , "def make_concrete() -> impl.Concrete:" + , " return impl.Concrete()" + , "" + , "class Derived(base.Base):" + , " pass" + , "" + , "class HeaderOnly(base.HeaderBase):" + , " pass" , "" , "def unused_b() -> int:" , " return 22" ] + writeFile (srcDir "proto.act") $ unlines + [ "protocol Proto:" + , " val : () -> int" + ] + writeFile (srcDir "leaf.act") $ unlines + [ "class Leaf(object):" + , " def __init__(self):" + , " pass" + , " def answer(self) -> int:" + , " return 44" + ] + writeFile (srcDir "impl.act") $ unlines + [ "import leaf" + , "import proto" + , "" + , "class Concrete(object):" + , " def __init__(self):" + , " pass" + , " def next(self) -> leaf.Leaf:" + , " return leaf.Leaf()" + , " def unused(self) -> int:" + , " return 99" + , " def _hidden(self) -> int:" + , " return 100" + , "" + , "extension Concrete(proto.Proto):" + , " def val(self) -> int:" + , " return 42" + ] + writeFile (srcDir "base.act") $ unlines + [ "class Field(object):" + , " def __init__(self):" + , " pass" + , "" + , "class HeaderBase(object):" + , " hidden: Field" + , " def __init__(self):" + , " self.hidden = Field()" + , "" + , "class Base(object):" + , " def __init__(self):" + , " self._padding = 1" + , " self.used = 7" + , " def inherited(self) -> int:" + , " return self.used" + , " def uncalled(self) -> int:" + , " return 987654321" + , " def _hidden(self) -> int:" + , " return 876543210" + ] writeFile (srcDir "c.act") $ unlines [ "import b" , "" , "actor main(env):" - , " print(b.exposed())" + , " print(b.exposed() + b.call_protocol())" , " env.exit(0)" ] - logTxt <- assertOk "dbp skips library boundary" =<< - runBuild ["build", "--skip-build", "--verbose", "--color", "never", "src/c.act"] + writeFile (srcDir "d.act") $ unlines + [ "def independent() -> int:" + , " return 33" + ] + logTxt <- assertOk "dbp keeps consumer-specific library dependencies" =<< + runBuild ["build", "--verbose", "--color", "never", "src/c.act"] writeFile (proj "log.txt") logTxt - assertBool "internal library module should still run DBP" - ("DBP a: total names" `isInfixOf` logTxt) - assertBool "boundary library module should not run DBP" - (not ("DBP b:" `isInfixOf` logTxt)) + assertBool "internal library dependency should remain selective" + ("Selective back a:" `isInfixOf` logTxt) + assertBool "protocol implementation should remain selective" + ("Selective back impl:" `isInfixOf` logTxt) + assertBool "inherited provider should remain selective" + ("Selective back base:" `isInfixOf` logTxt) + assertBool "boundary library module should remain whole" + (not ("Selective back b:" `isInfixOf` logTxt)) + assertBool "independent library sibling should remain whole" + (not ("Selective back d:" `isInfixOf` logTxt)) aC <- readFile (typesDir "a.c") bC <- readFile (typesDir "b.c") + dC <- readFile (typesDir "d.c") + implC <- readFile (typesDir "impl.c") + baseC <- readFile (typesDir "base.c") + baseH <- readFile (typesDir "base.h") + leafC <- readFile (typesDir "leaf.c") assertBool "internal DBP module should keep used name" ("used" `isInfixOf` aC) - assertBool "internal DBP module should omit unused name" (not ("unused_a" `isInfixOf` aC)) + assertBool "internal library dependency should omit its unused surface" (not $ "unused_a" `isInfixOf` aC) assertBool "boundary module should be compiled whole" ("unused_b" `isInfixOf` bC) + assertBool "independent sibling should be compiled whole" ("independent" `isInfixOf` dC) + assertBool "abstract return should retain its concrete protocol slot" + ((name ++ "Q_implQ_ProtoD_" ++ name ++ "D_protoD_ConcreteD_val") + `isInfixOf` implC) + assertBool "uncalled public method bodies should stay pruned" + (not $ "99LL" `isInfixOf` implC) + assertBool "uncalled private method bodies should stay pruned" + (not $ "100LL" `isInfixOf` implC) + assertBool "uncalled member result surfaces should stay pruned" + (not $ "leafQ_LeafD_answer" `isInfixOf` leafC) + assertBool "called inherited methods should route through the whole subclass" + ("baseQ_BaseD_inherited" `isInfixOf` baseC) + assertBool "uncalled inherited method bodies should stay pruned" + (not $ "987654321LL" `isInfixOf` baseC) + assertBool "uncalled private base method bodies should stay pruned" + (not $ "876543210LL" `isInfixOf` baseC) + assertBool "whole subclass layout should retain private inherited padding" + ("_padding" `isInfixOf` baseC) + assertBool "whole unconstructed subclass should retain its inherited property type declaration" + ("baseQ_Field" `isInfixOf` baseH) + assertBool "property type declaration should not select its constructor" + (not $ "baseQ_FieldG_new" `isInfixOf` baseC) + (runCode,runOut,runErr) <- readCreateProcessWithExitCode + (proc (proj "out" "bin" "c") []) "" + assertEqual ("boundary library binary should run: " ++ runErr) + ExitSuccess runCode + assertEqual "boundary library should execute its selected protocol implementation" + "50" (dropWhileEnd isSpace $ dropWhile isSpace runOut) + + , testCase "dbp keeps providers of native whole modules whole" $ do + withSystemTempDirectory "acton-dbp-native-provider" $ \proj -> do + actonExe <- canonicalizePath "../../dist/bin/acton" + let name = "dbp_native_provider" + fp = Fingerprint.formatFingerprint + (Fingerprint.updateFingerprintPrefix + (Fingerprint.fingerprintPrefixForName name) 1) + srcDir = proj "src" + typesDir = proj "out" "types" name + runBuild args = readCreateProcessWithExitCode + (proc actonExe + (["build", "--skip-build", "--verbose", "--color", "never"] ++ args)) + { cwd = Just proj } "" + assertOk label (code,out,err) = do + when (code /= ExitSuccess) $ + putStrLn ("\nERROR: " ++ label ++ "\nSTDOUT:\n" ++ out ++ "STDERR:\n" ++ err) + assertEqual label ExitSuccess code + return (out ++ err) + createDirectoryIfMissing True srcDir + writeFile (proj "Build.act") $ unlines + [ "name = \"" ++ name ++ "\"" + , "fingerprint = " ++ fp + ] + writeFile (srcDir "provider.act") $ unlines + [ "def used() -> int:" + , " return 1" + , "" + , "def unused() -> int:" + , " return 2" + ] + writeFile (srcDir "native.act") $ unlines + [ "import provider" + , "" + , "def native_hook(value: int) -> int:" + , " NotImplemented" + , "" + , "def call() -> int:" + , " return provider.used()" + ] + writeFile (srcDir "main.act") $ unlines + [ "import native" + , "" + , "actor main(env):" + , " print(native.call())" + , " env.exit(0)" + ] + firstLog <- assertOk "native provider closure build" =<< runBuild [] + assertBool "native provider should use a whole back pass" + ("Full back provider: full-module closure" `isInfixOf` firstLog) + assertBool "native provider should not be projected selectively" + (not $ "Selective back provider:" `isInfixOf` firstLog) + providerC <- readFile (typesDir "provider.c") + assertBool "whole native provider closure should retain unused definitions" + ("providerQ_unused" `isInfixOf` providerC) + secondLog <- assertOk "cached native provider closure build" =<< runBuild [] + assertBool "cached native provider should remain whole" + ("Full back provider: full-module closure" `isInfixOf` secondLog) + + , testCase "dbp skips explicitly requested rootless modules" $ do + withSystemTempDirectory "acton-dbp-mixed-surface" $ \proj -> do + actonExe <- canonicalizePath "../../dist/bin/acton" + let name = "dbp_mixed_surface" + fp = Fingerprint.formatFingerprint + (Fingerprint.updateFingerprintPrefix + (Fingerprint.fingerprintPrefixForName name) 1) + srcDir = proj "src" + typesDir = proj "out" "types" name + createDirectoryIfMissing True srcDir + writeFile (proj "Build.act") $ unlines + [ "name = \"" ++ name ++ "\"" + , "fingerprint = " ++ fp + ] + writeFile (srcDir "provider.act") $ unlines + [ "def used() -> int:" + , " return 1" + , "" + , "def required_by_api() -> int:" + , " return 2" + , "" + , "def unused() -> int:" + , " return 3" + ] + writeFile (srcDir "api.act") $ unlines + [ "import provider" + , "" + , "def exposed() -> int:" + , " return provider.required_by_api()" + ] + writeFile (srcDir "main.act") $ unlines + [ "import provider" + , "" + , "actor main(env):" + , " print(provider.used())" + , " env.exit(0)" + ] + (apiCode,apiOut,apiErr) <- readCreateProcessWithExitCode + (proc actonExe + [ "build", "--verbose", "--color", "never" + , "src/api.act" + ]){ cwd = Just proj } "" + when (apiCode /= ExitSuccess) $ + putStrLn ("\nERROR: rootless API build\nSTDOUT:\n" ++ apiOut ++ "STDERR:\n" ++ apiErr) + assertEqual "rootless API build" ExitSuccess apiCode + apiCExists <- doesFileExist (typesDir "api.c") + providerCExists <- doesFileExist (typesDir "provider.c") + assertBool "rootless API should not run back passes" (not apiCExists) + assertBool "rootless API should not seed provider back passes" (not providerCExists) + + (code,out,err) <- readCreateProcessWithExitCode + (proc actonExe + [ "build", "--skip-build", "--verbose", "--color", "never" + , "src/main.act", "src/api.act" + ]){ cwd = Just proj } "" + when (code /= ExitSuccess) $ + putStrLn ("\nERROR: mixed whole/selective build\nSTDOUT:\n" ++ out ++ "STDERR:\n" ++ err) + assertEqual "mixed whole/selective build" ExitSuccess code + let logTxt = out ++ err + assertBool "provider of executable root should remain selective" + ("Selective back provider:" `isInfixOf` logTxt) + providerC <- readFile (typesDir "provider.c") + assertBool "rootless API should not contribute provider interest" + (not $ "required_by_api" `isInfixOf` providerC) + assertBool "executable interest should remain present" + ("providerQ_used" `isInfixOf` providerC) + assertBool "uninterested provider code should be absent" + (not $ "providerQ_unused" `isInfixOf` providerC) , testCase "path dependency fetches transitive cached deps before discovery" $ do withSystemTempDirectory "acton-transitive-path-fetch" $ \tmp -> do @@ -842,6 +1651,10 @@ compilerTests = , "" , "def stale() -> int:" , " return dep.legacy.legacy()" + , "" + , "actor main(env: Env):" + , " print(stale())" + , " env.exit(0)" ] writeBuildActAt appProj "app" [("mid", midProj), ("dep", depV2)] @@ -1005,18 +1818,35 @@ parseFlagTests = assertBool "no-dbp option should be set" (C.no_dbp (C.buildCompile buildOpts)) _ -> assertFailure "expected build command" + , testCase "sig parser accepts project reachability without a target" $ do + parsed <- parseArgs ["sig", "--reachability"] + case parsed of + C.CmdOpt _ (C.Sig sigOpts) -> do + assertEqual "project target" Nothing (C.sigTarget sigOpts) + assertBool "reachability option should be set" + (C.sigReachability sigOpts) + _ -> + assertFailure "expected sig command" + , testCase "sig parser accepts dot as the project target" $ do + parsed <- parseArgs ["sig", "--reachability", "."] + case parsed of + C.CmdOpt _ (C.Sig sigOpts) -> + assertEqual "project target" (Just ".") (C.sigTarget sigOpts) + _ -> + assertFailure "expected sig command" , testCase "build parser help includes --release alias" $ do helpText <- renderParserHelp ["build", "--help"] assertBool "help text should include --release" ("--release" `isInfixOf` helpText) assertBool "help text should mention release variants" ("=safe or =small" `isInfixOf` helpText) assertBool "help text should mention default release mode" ("same as --release=fast" `isInfixOf` helpText) , testCase "sig parser accepts target and project options" $ do - parsed <- parseArgs ["sig", "--always-build", "--dep", "dep=../dep", "--searchpath", "out/types", "foo.bar"] + parsed <- parseArgs ["sig", "--always-build", "--reachability", "--dep", "dep=../dep", "--searchpath", "out/types", "foo.bar"] case parsed of C.CmdOpt _ (C.Sig sigOpts) -> do let opts = C.sigCompile sigOpts - assertEqual "sig target" "foo.bar" (C.sigTarget sigOpts) + assertEqual "sig target" (Just "foo.bar") (C.sigTarget sigOpts) assertBool "sig should force rebuild when requested" (C.alwaysbuild opts) + assertBool "sig should request reachability" (C.sigReachability sigOpts) assertEqual "sig searchpath" ["out/types"] (C.searchpath opts) assertEqual "sig dep overrides" [("dep", "../dep")] (C.dep_overrides opts) assertBool "sig should skip final build" (C.skip_build opts) @@ -1297,7 +2127,20 @@ parseFlagTests = (returnCode, cmdOut, cmdErr) <- readCreateProcessWithExitCode (proc acton (flags ++ [sample])) "" assertEqual ("acton " ++ unwords flags ++ " should succeed") ExitSuccess returnCode assertEqual ("acton " ++ unwords flags ++ " stderr") "" cmdErr - return (LBS.pack cmdOut) + return (LBS.pack $ normalizeCodegenHashes cmdOut) + + normalizeCodegenHashes = unlines . map normalize . lines + where + normalize line + | validCodegenHash line = + "/* Acton codegen hash: test-hash */" + | otherwise = line + validCodegenHash line = case stripPrefix prefix line of + Just rest -> length rest == 67 && + all isHexDigit (take 64 rest) && + drop 64 rest == " */" + Nothing -> False + prefix = "/* Acton codegen hash: " actonProjTests = testGroup "compiler project tests" diff --git a/compiler/acton/test_incremental.hs b/compiler/acton/test_incremental.hs index a739e715d..6c4de2b31 100644 --- a/compiler/acton/test_incremental.hs +++ b/compiler/acton/test_incremental.hs @@ -20,6 +20,7 @@ import System.Environment (getEnvironment) import System.Exit import System.FilePath import System.IO (Handle) +import System.IO.Temp (withSystemTempDirectory) import System.Posix.Files (deviceID, fileID, fileSize, getFileStatus, modificationTimeHiRes, statusChangeTimeHiRes) import System.Process import System.Timeout (timeout) @@ -36,6 +37,7 @@ import Test.Tasty.HUnit import qualified Acton.Compile as Compile import qualified Acton.CommandLineParser as C import qualified Acton.DocPrinter as DocP +import qualified Acton.Hashing as Hashing import qualified Acton.SourceProvider as Source import qualified Acton.NameInfo as I import qualified Acton.Syntax as A @@ -175,7 +177,7 @@ stale = statusReported "Stale" -- | Whether any line reports " :" for the given module. The -- module name is anchored right after the keyword, so a module name that appears --- later in some other line (e.g. an "{impl c missing}" codegen delta on a +-- later in some other line (e.g. a "{codegen c missing}" delta on a -- different module's line) cannot cause a cross-module false match. statusReported :: T.Text -> T.Text -> T.Text -> Bool statusReported keyword out modName = @@ -501,21 +503,16 @@ heavyClassModule trees = -- | Rewrite source hash and name-hash section of a .tydb file. rewriteTySrcHashAndNameHashes :: FilePath -> B.ByteString -> ([InterfaceFiles.NameHashInfo] -> [InterfaceFiles.NameHashInfo]) -> IO () rewriteTySrcHashAndNameHashes tyPath srcHash' f = do - (_mods, nmod, tmod, sourceMeta, _srcHash, pubHash, implHash, imps, depModules, nameHashes, roots, tests, mdoc) <- InterfaceFiles.readFile tyPath + (_sourceMeta, _srcHash, _pubHash, _implHash, _imps, depModules, nameHashes, _roots, _tests, _mdoc) <- + InterfaceFiles.readHeader tyPath nameHashes' <- restoreExternalDeps tyPath depModules nameHashes - InterfaceFiles.writeFile tyPath srcHash' pubHash implHash sourceMeta imps depModules (f nameHashes') roots tests mdoc nmod tmod + InterfaceFiles.updateSourceHashAndNameHashes tyPath srcHash' depModules (f nameHashes') rewriteTySourceMeta :: FilePath -> Maybe InterfaceFiles.SourceFileMeta -> IO () -rewriteTySourceMeta tyPath sourceMeta' = do - (_mods, nmod, tmod, _sourceMeta, srcHash, pubHash, implHash, imps, depModules, nameHashes, roots, tests, mdoc) <- InterfaceFiles.readFile tyPath - nameHashes' <- restoreExternalDeps tyPath depModules nameHashes - InterfaceFiles.writeFile tyPath srcHash pubHash implHash sourceMeta' imps depModules nameHashes' roots tests mdoc nmod tmod +rewriteTySourceMeta = InterfaceFiles.updateSourceMeta rewriteTyVersion :: FilePath -> [Int] -> IO () -rewriteTyVersion tyPath version' = do - (_mods, nmod, tmod, sourceMeta, srcHash, pubHash, implHash, imps, depModules, nameHashes, roots, tests, mdoc) <- InterfaceFiles.readFile tyPath - nameHashes' <- restoreExternalDeps tyPath depModules nameHashes - InterfaceFiles.writeFileWithVersion version' tyPath srcHash pubHash implHash sourceMeta imps depModules nameHashes' roots tests mdoc nmod tmod +rewriteTyVersion = InterfaceFiles.updateVersion readTySourceMeta :: FilePath -> IO (Maybe InterfaceFiles.SourceFileMeta) readTySourceMeta tyPath = do @@ -550,6 +547,48 @@ restoreExternalDeps tyPath depModules nameHashes = do merge (p1, i1) (p2, i2) = (p1 ++ p2, i1 ++ i2) pure (foldl addImpl (foldl addPub acc (InterfaceFiles.duPubUsers users)) (InterfaceFiles.duImplUsers users)) +-- | Move one binding's external dependency rows into the mandatory module +-- component. Source-level top assignments necessarily have an owner, while +-- front transformations can introduce ownerless initialization. This helper +-- exercises the incremental scheduler's persisted module-component path +-- without inventing source syntax that the language deliberately rejects. +moveBindingDepsToModuleHash :: FilePath -> String -> IO () +moveBindingDepsToModuleHash tyPath binding = do + refreshInput <- InterfaceFiles.readImplRefreshInput tyPath + let depModules = InterfaceFiles.iriDependencies refreshInput + nameHashes = InterfaceFiles.iriNameHashes refreshInput + storedModuleHash = InterfaceFiles.iriModuleHashInfo refreshInput + selected <- case find ((== binding) . prstr . InterfaceFiles.nhName) nameHashes of + Nothing -> assertFailure ("missing binding " ++ binding ++ " in " ++ tyPath) >> error "unreachable" + Just info -> return info + let withoutBindingDeps info + | InterfaceFiles.nhName info == InterfaceFiles.nhName selected = info + { InterfaceFiles.nhPubDeps = [] + , InterfaceFiles.nhImplDeps = [] + } + | otherwise = info + updatedNameHashes = map withoutBindingDeps nameHashes + implHashes = M.fromList + [ (InterfaceFiles.nhName info, InterfaceFiles.nhImplHash info) + | info <- updatedNameHashes + ] + updatedModuleHash = Hashing.finishModuleHash + implHashes + (InterfaceFiles.mhOwnImplHash storedModuleHash) + (InterfaceFiles.mhStatementOwners storedModuleHash) + (InterfaceFiles.mhImplLocalDeps storedModuleHash) + (InterfaceFiles.nhPubDeps selected) + (InterfaceFiles.nhImplDeps selected) + updatedImplHash = + Hashing.moduleImplHashFromNameHashes updatedModuleHash updatedNameHashes + InterfaceFiles.updateImplRefresh tyPath refreshInput + InterfaceFiles.ImplRefreshOutput + { InterfaceFiles.iroImplementationHash = updatedImplHash + , InterfaceFiles.iroModuleHashInfo = updatedModuleHash + , InterfaceFiles.iroDependencies = depModules + , InterfaceFiles.iroNameHashes = updatedNameHashes + } + sourceFileMetaForPath :: FilePath -> IO InterfaceFiles.SourceFileMeta sourceFileMetaForPath path = do st <- getFileStatus path @@ -733,11 +772,12 @@ p10_change_a_iface = testCase "10-change-a-iface" $ do assertBool "expected pub-change propagation a->b" (T.isInfixOf "pub changes in rebuild.a.aaa" out) assertBool "expected pub-change propagation b->c" (T.isInfixOf "pub changes in rebuild.b.baa" out) --- Docstring-only change in an imported module should not rebuild dependents +-- Docstring-only change in an imported module should not rebuild generated code p11_change_b_doc :: TestTree p11_change_b_doc = testCase "11-change-b-doc" $ do - -- Change only the docstring of a method in b.act; this should recompile b - -- (source changed) but not its dependent c (public hash is doc-free). + -- Change only the docstring of an unused method in b.act. The front passes + -- refresh b's source rows, but neither b's selected code nor dependent c + -- changes. writeFileUtf8 (srcDir "b.act") $ T.unlines [ "import a" , "def baa():" @@ -750,11 +790,11 @@ p11_change_b_doc = testCase "11-change-b-doc" $ do , " return 1" ] out <- buildOut - -- Doc-only change to b recompiles b (source changed) but its public hash is - -- doc-free, so c stays fresh -- the change does not propagate. a is untouched. + -- The public hash is doc-free, so c stays fresh. Since DocInfo is outside + -- the active projection, b's generated code stays fresh too. assertBool "expected a to stay fresh" (fresh out "rebuild/a") assertBool "expected b.act to type check" (typechecked out "rebuild/b") - assertBool "expected b.act to compile" (compiled out "rebuild/b") + assertBool "did not expect b.act codegen" (not $ compiled out "rebuild/b") assertBool "expected c to stay fresh (doc change does not propagate)" (fresh out "rebuild/c") p12_codegen_stale :: TestTree @@ -1196,7 +1236,7 @@ p23_codegen_mismatch = testCase "23-codegen hash mismatch triggers rebuild" $ do , " env.exit(0)" ] _ <- buildOutIn proj - rewriteFirstLine bC "/* Acton impl hash: deadbeef */" + rewriteFirstLine bC "/* Acton codegen hash: deadbeef */" out <- buildOutIn proj assertBool "expected codegen stale message" (T.isInfixOf "generated code out of date" out) assertBool "expected b.act to compile codegen" (compiled out modB) @@ -1230,11 +1270,11 @@ p24_codegen_equal_hash = testCase "24-codegen equal hash mismatch formats single -- The single-delta message is emitted by the EAGER codegen refresh; under -- default-on DBP the module would be deferred, so pin this path explicitly. _ <- buildOutInArgs proj ["--no-dbp"] - rewriteFirstLine bC "/* Acton impl hash: deadbeef */" - rewriteFirstLine bH "/* Acton impl hash: deadbeef */" + rewriteFirstLine bC "/* Acton codegen hash: deadbeef */" + rewriteFirstLine bH "/* Acton codegen hash: deadbeef */" out <- buildOutInArgs proj ["--no-dbp"] assertBool "expected single-delta codegen message" - (T.isInfixOf "generated code out of date {impl deadbeef ->" out) + (T.isInfixOf "generated code out of date {codegen deadbeef ->" out) assertBool "expected b.act to compile codegen" (compiled out modB) assertBool "did not expect b.act to type check" (not (typechecked out modB)) @@ -1242,6 +1282,7 @@ p25_whitespace_change :: TestTree p25_whitespace_change = testCase "25-whitespace-only change does not propagate" $ do let proj = casesProjDir src = casesSrcDir + modA = modLabel proj "a" modB = modLabel proj "b" modC = modLabel proj "c" ensureCasesProject @@ -1272,6 +1313,28 @@ p25_whitespace_change = testCase "25-whitespace-only change does not propagate" assertBool "did not expect b.act to type check" (not (typechecked out modB)) assertBool "did not expect c.act to type check" (not (typechecked out modC)) + -- Whole output carries source line mappings, so a source-only change must + -- refresh this module even though its semantic implementation is unchanged. + -- The raw source hash belongs to the codegen key, not dependency hashes, and + -- therefore must not propagate to consumers. + _ <- buildOutInArgs proj ["--no-dbp"] + writeFileUtf8 (src "a.act") $ T.unlines + [ "# another comment" + , "def foo() -> int:" + , " return 1" + ] + wholeOut <- buildOutInArgs proj ["--no-dbp"] + assertBool "expected a.act whole codegen after source-only change" + (compiled wholeOut modA) + assertBool "did not expect b.act to type check after source-only change" + (not $ typechecked wholeOut modB) + assertBool "did not expect c.act to type check after source-only change" + (not $ typechecked wholeOut modC) + assertBool "did not expect b.act codegen after source-only change" + (not $ compiled wholeOut modB) + assertBool "did not expect c.act codegen after source-only change" + (not $ compiled wholeOut modC) + p26_corrupt_ty_header :: TestTree p26_corrupt_ty_header = testCase "26-corrupt .tydb header forces re-parse" $ do let proj = casesProjDir @@ -2358,9 +2421,9 @@ p45_tydb_records_local_name_dependencies = p46_huge_module_skips_doc_output :: TestTree p46_huge_module_skips_doc_output = - testCase "46-huge module skips doc output" $ do + testCase "46-huge module skips doc output" $ + withSystemTempDirectory "acton-doc-index" $ \docDir -> do let opts = Compile.defaultCompileOptions - docDir = casesProjDir "doc-index" assertBool "doc output should run at the threshold" (Compile.shouldGenerateDocOutput opts False Compile.docNameCountThreshold) assertBool "doc output should skip above the threshold" @@ -2369,8 +2432,6 @@ p46_huge_module_skips_doc_output = (not (Compile.shouldGenerateDocOutput opts{ C.skip_build = True } False 1)) assertBool "temporary builds should skip doc output" (not (Compile.shouldGenerateDocOutput opts True 1)) - removeDirIfExists docDir - createDirectoryIfMissing True docDir DocP.generateDocIndex docDir [(A.modName ["huge"], Just "Huge module", False)] index <- T.readFile (docDir "index.html") assertBool "skipped module should remain visible" @@ -2389,7 +2450,9 @@ p47_unchanged_dep_reads_module_hashes_only = writeHashTraceMain buildHashTraceDep depDir buildHashTraceRoot - out <- buildTraceOutInArgs proj hashTraceBuildArgs + -- This case isolates unchanged front-cache validation. Selective back + -- passes intentionally read the exact selected name and reachability rows. + out <- buildTraceOutInArgs proj (hashTraceBuildArgs ++ ["--no-dbp"]) let bigTrace = traceLinesForTydb "big_dep/big" out assertTraceHas "big_dep.big should be checked by module hash" "module-hashes" bigTrace assertTraceLacks "big_dep.big should not scan all name hashes" "name-hash-all" bigTrace @@ -2504,6 +2567,8 @@ hashTraceBuildArgs = ["--skip-build", "--searchpath", "deps/big/out/types"] broadReadMarkers :: [T.Text] broadReadMarkers = [ "tydb-read all" + , "tydb-read iface" + , "tydb-read module-rows" , "tydb-read public-names" , "tydb-read constructors" , "tydb-read name-hash-all" @@ -2761,7 +2826,7 @@ p55_dbp_reads_selected_statements = bigLines = traceLinesForTydb "incremental_cases/big" out bigForbiddenLines = filter (\line -> any (`T.isInfixOf` line) broadReadMarkers) bigLines bigNodeLines = filter (\line -> T.isInfixOf "name-hash" line && T.isInfixOf "Node000A" line) bigLines - bigStmtLines = filter (T.isInfixOf "tydb-read stmts") bigLines + bigStmtLines = filter (T.isInfixOf "tydb-read selection") bigLines assertBool ("expected small.act to type check\n" ++ T.unpack out) (typechecked out modSmall) assertBool ("expected exact Node000A hash lookup in incremental_cases/big.tydb\ntrace:\n" ++ T.unpack (T.unlines traceLines)) (not (null bigNodeLines)) @@ -2769,6 +2834,10 @@ p55_dbp_reads_selected_statements = (not (null bigStmtLines)) assertEqual ("did not expect broad incremental_cases/big.tydb reads\ntrace:\n" ++ T.unpack (T.unlines traceLines)) [] bigForbiddenLines + buildRes <- runActonIn proj ["build", "--color", "never"] + assertExitSuccess "selective subset compiles and links" buildRes + runOut <- runBinaryIn proj "small" + assertEqual "selective binary output" "844" (T.unpack $ T.strip runOut) p54_unused_import_reads_no_names :: TestTree p54_unused_import_reads_no_names = @@ -2803,6 +2872,89 @@ p54_unused_import_reads_no_names = assertEqual ("did not expect any broad or name reads from unused incremental_cases/big.tydb\ntrace:\n" ++ T.unpack (T.unlines traceLines)) [] bigForbiddenLines +p56_module_dep_impl_change_refreshes_back :: TestTree +p56_module_dep_impl_change_refreshes_back = + testCase "56-module dependency impl change refreshes back passes" $ do + let proj = casesProjDir + src = casesSrcDir + modMain = modLabel proj "main" + tyMain = proj "out" "types" casesProjName "main.tydb" + ensureCasesProjectWithDeps [("libfoo", "deps/libfoo")] + depDir <- ensureDepProject proj "libfoo" + let depSrc = depDir "src" "lib.act" + writeFileUtf8 depSrc $ T.unlines + [ "def calculate() -> int:" + , " return 1" + ] + writeFileUtf8 (src "main.act") $ T.unlines + [ "import libfoo.lib" + , "" + , "value = libfoo.lib.calculate()" + , "" + , "actor main(env: Env):" + , " print(value)" + , " env.exit(0)" + ] + res1 <- runActonIn proj ["build", "--color", "never", "--skip-build"] + assertExitSuccess "initial module dependency build" res1 + moveBindingDepsToModuleHash tyMain "value" + moduleHash <- InterfaceFiles.readModuleHashInfo tyMain + assertDepsContain "module impl deps" ["libfoo.lib.calculate"] + (map (prstr . fst) $ InterfaceFiles.mhImplDeps moduleHash) + writeFileUtf8 depSrc $ T.unlines + [ "def calculate() -> int:" + , " return 2" + ] + res2@(_ec2, out2) <- + runActonIn proj ["build", "--color", "never", "--verbose", "--skip-build"] + assertExitSuccess "rebuild after module dependency impl change" res2 + assertBool ("expected module impl-change refresh\n" ++ T.unpack out2) + (T.isInfixOf "impl changes in libfoo.lib.calculate" out2) + assertBool ("did not expect main.act to rerun front passes\n" ++ T.unpack out2) + (not $ typechecked out2 modMain) + assertBool ("expected main.act to rerun back passes\n" ++ T.unpack out2) + (compiled out2 modMain) + +p57_module_dep_pub_change_reruns_front :: TestTree +p57_module_dep_pub_change_reruns_front = + testCase "57-module dependency pub change reruns front passes" $ do + let proj = casesProjDir + src = casesSrcDir + tyMain = proj "out" "types" casesProjName "main.tydb" + ensureCasesProjectWithDeps [("libfoo", "deps/libfoo")] + depDir <- ensureDepProject proj "libfoo" + let depSrc = depDir "src" "lib.act" + writeFileUtf8 depSrc $ T.unlines + [ "def calculate() -> int:" + , " return 1" + ] + writeFileUtf8 (src "main.act") $ T.unlines + [ "import libfoo.lib" + , "" + , "value = libfoo.lib.calculate()" + , "" + , "actor main(env: Env):" + , " print(value)" + , " env.exit(0)" + ] + res1 <- runActonIn proj ["build", "--color", "never", "--skip-build"] + assertExitSuccess "initial module dependency build" res1 + moveBindingDepsToModuleHash tyMain "value" + moduleHash <- InterfaceFiles.readModuleHashInfo tyMain + assertDepsContain "module pub deps" ["libfoo.lib.calculate"] + (map (prstr . fst) $ InterfaceFiles.mhPubDeps moduleHash) + writeFileUtf8 depSrc $ T.unlines + [ "def calculate(value: int) -> int:" + , " return value" + ] + res2@(_ec2, out2) <- + runActonIn proj ["build", "--color", "never", "--verbose", "--skip-build"] + assertExitFailure "rebuild after module dependency pub change" 1 res2 + assertBool ("expected module pub-change front refresh\n" ++ T.unpack out2) + (T.isInfixOf "pub changes in libfoo.lib.calculate" out2) + assertBool ("expected refreshed module call to fail type checking\n" ++ T.unpack out2) + (T.isInfixOf "keyword component(s) 'value' is missing in tuple" out2) + -- Main ----------------------------------------------------------------------- -- | Tasty entry point for incremental tests. @@ -2882,5 +3034,7 @@ main = defaultMain $ localOption (NumThreads 1) $ testGroup "incremental" , p53_imported_attr_inference_stays_selective , p54_unused_import_reads_no_names , p55_dbp_reads_selected_statements + , p56_module_dep_impl_change_refreshes_back + , p57_module_dep_pub_change_reruns_front ] ] diff --git a/compiler/lib/test/ActonSpec.hs b/compiler/lib/test/ActonSpec.hs index 531df4a09..7f43b8dc8 100644 --- a/compiler/lib/test/ActonSpec.hs +++ b/compiler/lib/test/ActonSpec.hs @@ -2,7 +2,7 @@ module Main (main) where -import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay) +import Control.Concurrent (newEmptyMVar, putMVar, runInBoundThread, takeMVar, threadDelay) import Control.Concurrent.Async (async, mapConcurrently_, wait) import Data.Char (toLower, isAlphaNum) @@ -30,6 +30,11 @@ import qualified Acton.CommandLineParser as C import qualified Acton.Fingerprint as Fingerprint import qualified Acton.Completion as Completion import qualified Acton.Hashing as Hashing +import qualified Acton.Names as Names +import qualified Acton.InterfaceRows as InterfaceRows +import qualified Acton.Reachability as Reachability +import qualified Acton.ReachabilityPrinter as ReachabilityPrinter +import qualified Acton.ReachabilityRows as ReachRows import qualified InterfaceFiles import Pretty (print, prettyText) import qualified Pretty @@ -40,12 +45,13 @@ import qualified Control.Monad.Trans.State.Strict as St import Text.Megaparsec (ParseErrorBundle, PosState(..), bundleErrors, bundlePosState, errorOffset, reachOffset, runParser, errorBundlePretty, ShowErrorComponent(..)) import Text.Megaparsec.Pos (sourceLine, unPos) import qualified Data.Text as T -import Data.List (isInfixOf, isPrefixOf, nub, sort) +import Data.List (isInfixOf, isPrefixOf, nub, sort, sortOn) import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import qualified Data.Set as Set import Data.IORef import Data.Bits (shiftL, (.|.)) +import Data.Functor.Identity (runIdentity) import qualified Data.ByteString.Base16 as Base16 import Error.Diagnose (printDiagnostic, prettyDiagnostic, WithUnicode(..), TabSize(..), defaultStyle, addReport, addFile) import Error.Diagnose.Report (Report(..)) @@ -65,6 +71,8 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as B8 import qualified Data.Aeson as Ae import qualified System.IO.Unsafe +import qualified Database.LMDB.Raw as LMDB +import Foreign.Ptr (castPtr) nameHash :: S.Name -> B8.ByteString -> B8.ByteString -> B8.ByteString -> InterfaceFiles.NameHashInfo @@ -82,6 +90,179 @@ nameHash n src pub impl = , InterfaceFiles.nhStmtIndices = [] } +interfaceContents :: I.NModule -> InterfaceRows.InterfaceRows -> InterfaceFiles.InterfaceContents +interfaceContents nmod rows = + InterfaceFiles.InterfaceContents + { InterfaceFiles.ifcSourceHash = "src" + , InterfaceFiles.ifcPublicHash = "pub" + , InterfaceFiles.ifcImplementationHash = "impl" + , InterfaceFiles.ifcModuleHashInfo = InterfaceFiles.emptyModuleHashInfo + , InterfaceFiles.ifcSourceMeta = Nothing + , InterfaceFiles.ifcImports = [] + , InterfaceFiles.ifcDependencies = [] + , InterfaceFiles.ifcNameHashes = [] + , InterfaceFiles.ifcRoots = [] + , InterfaceFiles.ifcTests = [] + , InterfaceFiles.ifcDoc = Nothing + , InterfaceFiles.ifcModule = nmod + , InterfaceFiles.ifcRows = rows + , InterfaceFiles.ifcReachabilityRows = ReachRows.emptyReachabilityRows + } + +moduleRowsFor :: Acton.Env.Env0 -> S.Module -> InterfaceRows.InterfaceRows +moduleRowsFor env tmod = + case Reachability.prepareInterfaceRows env tmod of + Left err -> error (show err) + Right rows -> rows + +rowShapesList :: InterfaceRows.InterfaceRows -> [InterfaceRows.ContainerShape] +rowShapesList = M.elems . InterfaceRows.rowShapes + +rowMemberEntries :: InterfaceRows.InterfaceRows -> [(S.Name, InterfaceRows.MemberKey, InterfaceRows.MemberContent)] +rowMemberEntries rows = + [ (owner, key, content) + | (owner, members) <- M.toList (InterfaceRows.rowMembers rows) + , (key, content) <- M.toList members + ] + +initBodyEntries :: InterfaceRows.MemberContent -> [(Int, S.Stmt)] +initBodyEntries content = + [ (i, stmt) + | InterfaceRows.ConstructorFragment i stmt <- initializers content + ] + where + initializers (InterfaceRows.InitializerContent inits) = inits + initializers InterfaceRows.InitRestContent{InterfaceRows.restInitializers=inits} = inits + initializers _ = [] + +initSuiteEntries :: InterfaceRows.MemberContent -> [(Int, S.Stmt)] +initSuiteEntries content = + [ (hole, stmt) + | InterfaceRows.SuiteFragment hole stmt <- initializers content + ] + where + initializers (InterfaceRows.InitializerContent inits) = inits + initializers InterfaceRows.InitRestContent{InterfaceRows.restInitializers=inits} = inits + initializers _ = [] + +methodBodies :: InterfaceRows.MemberContent -> [S.Suite] +methodBodies (InterfaceRows.MethodContent methods) = map S.dbody methods +methodBodies _ = [] + +data SelectionIndex = SelectionIndex + { selectionTops :: M.Map ReachRows.TopKey ReachRows.TopInfo + , selectionMembers :: M.Map (ReachRows.TopKey,InterfaceRows.MemberKey) ReachRows.MemberInfo + , selectionShapes :: M.Map ReachRows.TopKey ReachRows.ShapeInfo + , selectionSlots :: M.Map (ReachRows.TopKey,ReachRows.MemberRef) ReachRows.SlotInfo + , selectionReflections :: M.Map ReachRows.TopKey ReachRows.ReflectableAttrs + } + +data SelectionFixture = SelectionFixture + { fixtureShape :: ReachRows.ShapeInfo + , fixtureSlots :: [(ReachRows.MemberRef,ReachRows.SlotInfo)] + } + +selectionClass :: ReachRows.TopKey + -> [ReachRows.TopKey] + -> [(ReachRows.MemberRef,ReachRows.SlotInfo)] + -> SelectionFixture +selectionClass owner lineage slots = SelectionFixture shape slots + where + shape = ReachRows.ShapeInfo owner ReachRows.ClassShape lineage + (Just (owner,ReachRows.StoredConstructor mempty)) + [ ref | (ref,ReachRows.SlotInfo _ ReachRows.AbstractSlot) <- slots ] + +selectionIndex :: [SelectionFixture] + -> [(ReachRows.TopKey,InterfaceRows.MemberKey,ReachRows.MemberInfo)] + -> [(ReachRows.TopKey,ReachRows.ReachSummary)] + -> SelectionIndex +selectionIndex fixtures givenMembers plain = SelectionIndex + { selectionTops = M.fromList + ([ (ReachRows.shapeName shape,ReachRows.LocalTop Nothing mempty) | shape <- shapes ] ++ + [ (owner,ReachRows.LocalTop Nothing summary) | (owner,summary) <- plain ]) + , selectionMembers = M.fromList + [ ((owner,key),info) | (owner,key,info) <- givenMembers ++ constructors ] + , selectionShapes = M.fromList [ (ReachRows.shapeName shape,shape) | shape <- shapes ] + , selectionSlots = M.fromList + [ ((ReachRows.shapeName $ fixtureShape fixture,ref),slot) + | fixture <- fixtures + , (ref,slot) <- fixtureSlots fixture + ] + , selectionReflections = M.fromList + [ ( ReachRows.shapeName $ fixtureShape fixture + , ReachRows.ReflectableAttrs + [ name | (ReachRows.AttrRef name,_) <- fixtureSlots fixture ] + ) + | fixture <- fixtures + ] + } + where + shapes = map fixtureShape fixtures + supplied = Set.fromList [ (owner,key) | (owner,key,_) <- givenMembers ] + constructors = + [ (owner,InterfaceRows.InitRest,ReachRows.MemberInfo mempty Nothing Nothing) + | shape <- shapes + , Just (owner,ReachRows.StoredConstructor _) <- [ReachRows.shapeConstructor shape] + , Set.notMember (owner,InterfaceRows.InitRest) supplied + ] + +selectionLookup :: Applicative m => SelectionIndex -> Reachability.ReachLookup m +selectionLookup index = Reachability.ReachLookup + { Reachability.lookupTopRow = \key -> pure $ M.lookup key (selectionTops index) + , Reachability.lookupMemberRow = \owner member -> + pure $ M.lookup (owner,member) (selectionMembers index) + , Reachability.lookupShapeRow = \key -> pure $ M.lookup key (selectionShapes index) + , Reachability.lookupSlotRow = \owner ref -> + pure $ M.lookup (owner,ref) (selectionSlots index) + , Reachability.lookupSurfaceSlots = \owner -> pure + [ (ref,slot) | ((owner',ref),slot) <- M.toAscList (selectionSlots index), owner == owner' ] + , Reachability.lookupReflectableAttrs = \owner -> + pure $ M.lookup owner (selectionReflections index) + } + +data SelectionCounts = SelectionCounts + { countTops :: M.Map ReachRows.TopKey Int + , countMembers :: M.Map (ReachRows.TopKey,InterfaceRows.MemberKey) Int + , countShapes :: M.Map ReachRows.TopKey Int + , countSlots :: M.Map (ReachRows.TopKey,ReachRows.MemberRef) Int + , countSurfaces :: M.Map ReachRows.TopKey Int + , countReflections :: M.Map ReachRows.TopKey Int + } deriving (Eq,Show) + +emptySelectionCounts :: SelectionCounts +emptySelectionCounts = SelectionCounts M.empty M.empty M.empty M.empty M.empty M.empty + +countedSelectionLookup :: SelectionIndex -> Reachability.ReachLookup (St.State SelectionCounts) +countedSelectionLookup index = Reachability.ReachLookup + { Reachability.lookupTopRow = \key -> count countTops setTops key $ + M.lookup key (selectionTops index) + , Reachability.lookupMemberRow = \owner member -> count countMembers setMembers + (owner,member) (M.lookup (owner,member) $ selectionMembers index) + , Reachability.lookupShapeRow = \key -> count countShapes setShapes key $ + M.lookup key (selectionShapes index) + , Reachability.lookupSlotRow = \owner ref -> count countSlots setSlots + (owner,ref) (M.lookup (owner,ref) $ selectionSlots index) + , Reachability.lookupSurfaceSlots = \owner -> count countSurfaces setSurfaces owner + [ (ref,slot) | ((owner',ref),slot) <- M.toAscList (selectionSlots index), owner == owner' ] + , Reachability.lookupReflectableAttrs = \owner -> count countReflections setReflections owner $ + M.lookup owner (selectionReflections index) + } + where + count field set key value = do + St.modify' (\counts -> set (M.insertWith (+) key 1 $ field counts) counts) + return value + setTops rows counts = counts{countTops=rows} + setMembers rows counts = counts{countMembers=rows} + setShapes rows counts = counts{countShapes=rows} + setSlots rows counts = counts{countSlots=rows} + setSurfaces rows counts = counts{countSurfaces=rows} + setReflections rows counts = counts{countReflections=rows} + +selectFixture :: SelectionIndex + -> [ReachRows.ReachEdge] + -> Either Reachability.SelectionError Reachability.Selection +selectFixture index = runIdentity . Reachability.selectProgram (selectionLookup index) + hashTestName :: S.Name hashTestName = S.name "value" @@ -107,6 +288,49 @@ sourceHashFor decl = Just h -> h Nothing -> error "missing source hash" +withInterfaceSession :: FilePath -> (InterfaceFiles.InterfaceReadSession -> IO a) -> IO a +withInterfaceSession = InterfaceFiles.withInterfaceReadSession + +deleteInterfaceEntry :: FilePath -> B8.ByteString -> IO () +deleteInterfaceEntry path entry = runInBoundThread $ do + env <- LMDB.mdb_env_create + E.bracket_ + (LMDB.mdb_env_open env path []) + (LMDB.mdb_env_close env) + (E.mask $ \restore -> do + txn <- LMDB.mdb_txn_begin env Nothing False + restore + (do dbi <- LMDB.mdb_dbi_open txn Nothing [] + B8.useAsCStringLen entry $ \(ptr,len) -> do + _ <- LMDB.mdb_del txn dbi + (LMDB.MDB_val (fromIntegral len) (castPtr ptr)) Nothing + return ()) + `E.onException` LMDB.mdb_txn_abort txn + LMDB.mdb_txn_commit txn) + +copyInterfaceEntry :: FilePath -> B8.ByteString -> B8.ByteString -> IO () +copyInterfaceEntry path source destination = runInBoundThread $ do + env <- LMDB.mdb_env_create + E.bracket_ + (LMDB.mdb_env_open env path []) + (LMDB.mdb_env_close env) + (E.mask $ \restore -> do + txn <- LMDB.mdb_txn_begin env Nothing False + restore + (do dbi <- LMDB.mdb_dbi_open txn Nothing [] + B8.useAsCStringLen source $ \(sourcePtr,sourceLen) -> do + value <- LMDB.mdb_get txn dbi + (LMDB.MDB_val (fromIntegral sourceLen) (castPtr sourcePtr)) + case value of + Nothing -> expectationFailure "source interface entry is missing" + Just bytes -> + B8.useAsCStringLen destination $ \(destinationPtr,destinationLen) -> do + _ <- LMDB.mdb_put (LMDB.compileWriteFlags []) txn dbi + (LMDB.MDB_val (fromIntegral destinationLen) (castPtr destinationPtr)) bytes + return ()) + `E.onException` LMDB.mdb_txn_abort txn + LMDB.mdb_txn_commit txn) + implSplitDepSetMaps :: Acton.Env.Env0 -> S.ModName -> Set.Set S.Name @@ -148,6 +372,7 @@ main :: IO () main = do let sysTypesPath = ".." ".." "dist" "base" "out" "types" env0 <- Acton.Env.initEnv sysTypesPath False + let moduleRows = moduleRowsFor env0 sydTest $ do describe "Zon (build.zig.zon reader)" $ do @@ -222,6 +447,223 @@ main = do got <- Zon.readZonDependencies p got `shouldBe` Right [ ("a", Zon.ZonDep (Just "u") (Just "h") Nothing False) ] sequential $ describe "InterfaceFiles" $ do + it "preserves ownerless whole statements and typed variable rows" $ do + let mn = S.modName ["iface_owned_tops"] + ownerlessStmt = S.Expr NoLoc (S.Int NoLoc 1 "1") + ownerlessModule = S.Module mn [] Nothing [ownerlessStmt] + ownerlessRows = InterfaceRows.InterfaceRows + { InterfaceRows.rowModuleName = mn + , InterfaceRows.rowImports = [] + , InterfaceRows.rowDoc = Nothing + , InterfaceRows.rowHasNotImpl = False + , InterfaceRows.rowStatements = [InterfaceRows.StoredWhole [] ownerlessStmt] + , InterfaceRows.rowShapes = M.empty + , InterfaceRows.rowMembers = M.empty + } + name = S.name "value" + variableStmt = S.VarAssign NoLoc + [S.PVar NoLoc name (Just S.tWild)] (S.Int NoLoc 1 "1") + variableModule = S.Module mn [] Nothing [variableStmt] + case Reachability.prepareInterfaceRows env0 ownerlessModule of + Left err -> expectationFailure (show err) + Right rows -> do + InterfaceRows.rowStatements rows `shouldBe` + [InterfaceRows.StoredWhole [] ownerlessStmt] + InterfaceRows.restoreInterfaceRows rows `shouldBe` Right ownerlessModule + InterfaceRows.restoreInterfaceRows ownerlessRows `shouldBe` Right ownerlessModule + case Reachability.prepareInterfaceRows env0 variableModule of + Left err -> expectationFailure (show err) + Right rows -> InterfaceRows.restoreInterfaceRows rows `shouldBe` Right variableModule + + it "owns and hashes bindings from compound top-level statements" $ do + withSystemTempDirectory "acton-iface-compound-top" $ \dir -> do + let mn = S.modName ["iface_compound_top_binding"] + tyPath = dir "iface_compound_top_binding.tydb" + value = S.name "value" + assign n = S.Assign NoLoc + [S.PVar NoLoc value (Just Builtin.tInt)] (S.Int NoLoc n (show n)) + conditional = S.If NoLoc + [S.Branch (S.Bool NoLoc True) [assign 1]] [assign 2] + typed = S.Module mn [] Nothing [conditional] + nmod = I.NModule [] [(value,I.NVar Builtin.tInt)] Nothing + hashes = Hashing.nameHashesFromItems + (Hashing.topLevelItems (Hashing.typedTopLevelOwners typed) typed) + rows = moduleRows typed + map InterfaceRows.storedStmtNames (InterfaceRows.rowStatements rows) + `shouldBe` [[value]] + M.member value hashes `shouldBe` True + InterfaceRows.restoreInterfaceRows rows `shouldBe` Right typed + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod rows) + { InterfaceFiles.ifcNameHashes = [nameHash value "src" "pub" "impl"] } + (_mods,_nmod,restored,_sourceMeta,_srcHash,_pubHash,_implHash, + _imps,_deps,_hashes,_roots,_tests,_doc) <- InterfaceFiles.readFile tyPath + restored `shouldBe` typed + + it "loads mandatory ownerless statements for an empty projection" $ do + withSystemTempDirectory "acton-iface-mandatory-statements" $ \dir -> do + let mn = S.modName ["iface_mandatory_statements"] + tyPath = dir "iface_mandatory_statements.tydb" + stmt = S.Expr NoLoc (S.Int NoLoc 1 "1") + tmod = S.Module mn [] Nothing [stmt] + nmod = I.NModule [] [] Nothing + InterfaceFiles.writeFile (\_ -> return ()) tyPath (interfaceContents nmod (moduleRows tmod)) + withInterfaceSession tyPath $ \session -> + InterfaceFiles.readInterfaceSessionSelection + session [] Set.empty M.empty + `shouldReturn` tmod + + it "round-trips the module-owned hash and dependency rows" $ do + withSystemTempDirectory "acton-iface-module-hash" $ \dir -> do + let mn = S.modName ["iface_module_hash"] + depMn = S.modName ["dependency"] + depName = S.name "value" + dep = S.GName depMn depName + tyPath = dir "iface_module_hash.tydb" + moduleHash = InterfaceFiles.ModuleHashInfo + { InterfaceFiles.mhOwnImplHash = "module-own" + , InterfaceFiles.mhStatementOwners = [] + , InterfaceFiles.mhImplHash = "module-impl" + , InterfaceFiles.mhImplLocalDeps = [] + , InterfaceFiles.mhPubDeps = [(dep,"dep-pub")] + , InterfaceFiles.mhImplDeps = [(dep,"dep-impl")] + } + depModule = InterfaceFiles.DepModuleInfo depMn "module-pub" "module-impl" + nmod = I.NModule [] [] Nothing + tmod = S.Module mn [] Nothing [] + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod (moduleRows tmod)) + { InterfaceFiles.ifcModuleHashInfo = moduleHash + , InterfaceFiles.ifcDependencies = [depModule] + } + InterfaceFiles.readModuleHashInfo tyPath `shouldReturn` moduleHash + InterfaceFiles.readDepNames tyPath depMn `shouldReturn` + [InterfaceFiles.DepNameInfo depName "dep-pub" "dep-impl"] + InterfaceFiles.readDepUsers tyPath depMn depName `shouldReturn` + InterfaceFiles.DepUsers [] [] + + it "refreshes the module-owned hash without rewriting typed content" $ do + withSystemTempDirectory "acton-iface-module-hash-refresh" $ \dir -> do + let mn = S.modName ["iface_module_hash_refresh"] + depMn = S.modName ["dependency"] + depName = S.name "value" + dep = S.GName depMn depName + tyPath = dir "iface_module_hash_refresh.tydb" + stmt = S.Expr NoLoc (S.Int NoLoc 1 "1") + tmod = S.Module mn [] Nothing [stmt] + nmod = I.NModule [] [] Nothing + moduleHash implHash = InterfaceFiles.ModuleHashInfo + { InterfaceFiles.mhOwnImplHash = "module-own" + , InterfaceFiles.mhStatementOwners = [[]] + , InterfaceFiles.mhImplHash = "module-component-" <> implHash + , InterfaceFiles.mhImplLocalDeps = [] + , InterfaceFiles.mhPubDeps = [(dep,"dep-pub")] + , InterfaceFiles.mhImplDeps = [(dep,implHash)] + } + initialHash = moduleHash "dep-impl-1" + refreshedHash = moduleHash "dep-impl-2" + initialDep = InterfaceFiles.DepModuleInfo depMn "module-pub" "module-impl-1" + refreshedDep = InterfaceFiles.DepModuleInfo depMn "module-pub" "module-impl-2" + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod (moduleRows tmod)) + { InterfaceFiles.ifcImplementationHash = "aggregate-1" + , InterfaceFiles.ifcModuleHashInfo = initialHash + , InterfaceFiles.ifcDependencies = [initialDep] + } + refreshInput <- InterfaceFiles.readImplRefreshInput tyPath + InterfaceFiles.updateImplRefresh tyPath refreshInput + InterfaceFiles.ImplRefreshOutput + { InterfaceFiles.iroImplementationHash = "aggregate-2" + , InterfaceFiles.iroModuleHashInfo = refreshedHash + , InterfaceFiles.iroDependencies = [refreshedDep] + , InterfaceFiles.iroNameHashes = [] + } + InterfaceFiles.readModuleHashInfo tyPath `shouldReturn` refreshedHash + InterfaceFiles.readModuleHashesMaybe tyPath `shouldReturn` + Just ("src","pub","aggregate-2") + InterfaceFiles.readDepNames tyPath depMn `shouldReturn` + [InterfaceFiles.DepNameInfo depName "dep-pub" "dep-impl-2"] + (_mods, _nmod, restored, _sourceMeta, _srcHash, _pubHash, _implHash, + _imps, _depModules, _nameHashes, _roots, _tests, _doc) <- + InterfaceFiles.readFile tyPath + restored `shouldBe` tmod + + it "rejects an implementation refresh planned from stale rows" $ do + withSystemTempDirectory "acton-iface-stale-impl-refresh" $ \dir -> do + let mn = S.modName ["iface_stale_impl_refresh"] + tyPath = dir "iface_stale_impl_refresh.tydb" + nmod = I.NModule [] [] Nothing + tmod = S.Module mn [] Nothing [] + output implHash = InterfaceFiles.ImplRefreshOutput + { InterfaceFiles.iroImplementationHash = implHash + , InterfaceFiles.iroModuleHashInfo = InterfaceFiles.emptyModuleHashInfo + , InterfaceFiles.iroDependencies = [] + , InterfaceFiles.iroNameHashes = [] + } + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod (moduleRows tmod)) + { InterfaceFiles.ifcImplementationHash = "impl-1" } + initial <- InterfaceFiles.readImplRefreshInput tyPath + InterfaceFiles.updateImplRefresh tyPath initial (output "impl-2") + InterfaceFiles.updateImplRefresh tyPath initial (output "stale") + `shouldThrow` InterfaceFiles.isImplRefreshStale + current <- InterfaceFiles.readImplRefreshInput tyPath + let wrongInputs = + [ current { InterfaceFiles.iriGeneration = "wrong" } + , current { InterfaceFiles.iriSourceHash = "wrong" } + , current { InterfaceFiles.iriPublicHash = "wrong" } + , current { InterfaceFiles.iriImplementationHash = "wrong" } + ] + forM_ wrongInputs $ \wrong -> + InterfaceFiles.updateImplRefresh tyPath wrong (output "stale") + `shouldThrow` InterfaceFiles.isImplRefreshStale + InterfaceFiles.readModuleHashesMaybe tyPath `shouldReturn` + Just ("src","pub","impl-2") + InterfaceFiles.updateImplRefresh tyPath current (output "impl-3") + InterfaceFiles.readModuleHashesMaybe tyPath `shouldReturn` + Just ("src","pub","impl-3") + + it "keeps structurally distinct module-name dependency rows separate" $ do + withSystemTempDirectory "acton-iface-module-keys" $ \dir -> do + let mn = S.modName ["iface_module_keys"] + plain = S.name "ownerD_part" + derived = S.Derived (S.name "owner") (S.name "part") + plainMn = S.ModName [plain] + derivedMn = S.ModName [derived] + depName = S.name "value" + plainDep = S.GName plainMn depName + derivedDep = S.GName derivedMn depName + tyPath = dir "iface_module_keys.tydb" + moduleHash = InterfaceFiles.ModuleHashInfo + { InterfaceFiles.mhOwnImplHash = "module-own" + , InterfaceFiles.mhStatementOwners = [] + , InterfaceFiles.mhImplHash = "module-impl" + , InterfaceFiles.mhImplLocalDeps = [] + , InterfaceFiles.mhPubDeps = + [(plainDep,"plain-pub"),(derivedDep,"derived-pub")] + , InterfaceFiles.mhImplDeps = + [(plainDep,"plain-impl"),(derivedDep,"derived-impl")] + } + depModules = + [ InterfaceFiles.DepModuleInfo plainMn "plain-module-pub" "plain-module-impl" + , InterfaceFiles.DepModuleInfo derivedMn "derived-module-pub" "derived-module-impl" + ] + nmod = I.NModule [] [] Nothing + tmod = S.Module mn [] Nothing [] + S.nstr plain `shouldBe` S.nstr derived + compare plain derived `shouldNotBe` EQ + S.modPath plainMn `shouldBe` S.modPath derivedMn + compare plainMn derivedMn `shouldNotBe` EQ + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod (moduleRows tmod)) + { InterfaceFiles.ifcModuleHashInfo = moduleHash + , InterfaceFiles.ifcDependencies = depModules + } + InterfaceFiles.readDepNames tyPath plainMn `shouldReturn` + [InterfaceFiles.DepNameInfo depName "plain-pub" "plain-impl"] + InterfaceFiles.readDepNames tyPath derivedMn `shouldReturn` + [InterfaceFiles.DepNameInfo depName "derived-pub" "derived-impl"] + it "round-trips payloads and preserves ordered name entries" $ do withSystemTempDirectory "acton-iface" $ \dir -> do let mn = S.modName ["iface"] @@ -250,12 +692,20 @@ main = do tests = ["test_second", "test_first"] nmod = I.NModule [] iface (Just "module docs") tmod = S.Module mn [] (Just "typed docs") [] - InterfaceFiles.writeFile tyPath "src" "pub" "impl" Nothing [] [] nameHashes roots tests (Just "module docs") nmod tmod - InterfaceFiles.keyNameInfo firstName `shouldBe` "name-info/p/first" + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod (moduleRows tmod)) + { InterfaceFiles.ifcNameHashes = nameHashes + , InterfaceFiles.ifcRoots = roots + , InterfaceFiles.ifcTests = tests + , InterfaceFiles.ifcDoc = Just "module docs" + } + InterfaceFiles.keyNameInfo firstName `shouldSatisfy` B8.isPrefixOf "name-info/h/" InterfaceFiles.keyNameInfo firstName `shouldNotBe` InterfaceFiles.keyNameInfo firstishName - InterfaceFiles.keyNameHash secondName `shouldBe` "name-hash/p/second" - InterfaceFiles.keyNameInfo sourcePlainName `shouldBe` "name-info/p/foo_bar" - InterfaceFiles.keyNameInfo derivedName `shouldBe` "name-info/p/encodeD_witness" + InterfaceFiles.keyNameHash secondName `shouldSatisfy` B8.isPrefixOf "name-hash/h/" + InterfaceFiles.keyNameInfo sourcePlainName `shouldSatisfy` B8.isPrefixOf "name-info/h/" + InterfaceFiles.keyNameInfo derivedName `shouldSatisfy` B8.isPrefixOf "name-info/h/" + InterfaceFiles.keyNameInfo sourcePlainName `shouldNotBe` + InterfaceFiles.keyNameInfo derivedName InterfaceFiles.keyNameInfo longName `shouldSatisfy` B8.isPrefixOf "name-info/h/" (_mods, I.NModule _ te mdoc, tmod', sourceMeta, srcHash, pubHash, implHash, imps, depModules, nameHashes', roots', tests', doc') <- InterfaceFiles.readFile tyPath @@ -266,7 +716,7 @@ main = do (srcHash, pubHash, implHash) `shouldBe` ("src", "pub", "impl") imps `shouldBe` [] depModules `shouldBe` [] - nameHashes' `shouldBe` nameHashes + nameHashes' `shouldBe` sortOn InterfaceFiles.nhName nameHashes roots' `shouldBe` roots tests' `shouldBe` tests doc' `shouldBe` Just "module docs" @@ -277,11 +727,122 @@ main = do (srcHashH, pubHashH, implHashH) `shouldBe` ("src", "pub", "impl") impsH `shouldBe` [] depModulesH `shouldBe` [] - nameHashesH `shouldBe` nameHashes + nameHashesH `shouldBe` sortOn InterfaceFiles.nhName nameHashes rootsH `shouldBe` roots testsH `shouldBe` tests docH `shouldBe` Just "module docs" + it "preserves repeated signature and definition name occurrences" $ do + withSystemTempDirectory "acton-iface-name-occurrences" $ \dir -> do + let mn = S.modName ["iface_name_occurrences"] + tyPath = dir "iface_name_occurrences.tydb" + value = S.name "value" + signature = I.NSig (S.monotype Builtin.tInt) S.NoDec Nothing + definition = I.NVar Builtin.tInt + iface = [(value,signature),(value,definition)] + nmod = I.NModule [] iface Nothing + rows = moduleRows (S.Module mn [] Nothing []) + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod rows) + { InterfaceFiles.ifcNameHashes = [nameHash value "src" "pub" "impl"] } + (_mods,I.NModule _ restored _,_typed,_sourceMeta,_srcHash,_pubHash, + _implHash,_imps,_depModules,_nameHashes,_roots,_tests,_doc) <- + InterfaceFiles.readFile tyPath + restored `shouldBe` iface + db <- InterfaceFiles.openInterfaceDB tyPath + InterfaceFiles.readInterfaceDBNameInfoMaybe db value + `shouldReturn` Just (value,definition) + + it "stores and reads exact reachability rows independently" $ do + withSystemTempDirectory "acton-iface-reachability" $ \dir -> do + let mn = S.modName ["iface_reachability"] + depMn = S.modName ["dependency"] + tyPath = dir "iface_reachability.tydb" + owner = S.name "Payload" + member = S.name "value" + self = S.name "self" + topKey = ReachRows.TopKey mn owner + memberKey = InterfaceRows.Method member + memberRef = ReachRows.MethodRef member + missingTop = ReachRows.TopKey mn (S.name "Missing") + summary = ReachRows.reachSummaryFromEdges + [ReachRows.Direct depMn (S.name "Other") (ReachRows.AttrRef (S.name "field"))] + topInfo = ReachRows.LocalTop Nothing summary + memberInfo = ReachRows.MemberInfo summary Nothing (Just mempty) + shapeInfo = ReachRows.ShapeInfo + topKey ReachRows.ClassShape [topKey] Nothing [] + slotInfo = ReachRows.SlotInfo topKey (ReachRows.StoredSlot memberKey) + reflection = ReachRows.ReflectableAttrs [member] + reachRows = ReachRows.ReachabilityRows + { ReachRows.reachModuleSummary = summary + , ReachRows.reachWholeSummary = summary <> summary + , ReachRows.reachTopRows = M.singleton topKey topInfo + , ReachRows.reachMemberRows = M.singleton (topKey, memberKey) memberInfo + , ReachRows.reachShapeRows = M.singleton topKey shapeInfo + , ReachRows.reachSlotRows = M.singleton (topKey, memberRef) slotInfo + , ReachRows.reachReflectableRows = M.singleton topKey reflection + } + method = S.Def NoLoc member [] + (S.PosPar self Nothing Nothing S.PosNIL) S.KwdNIL Nothing + [S.Return NoLoc Nothing] S.NoDec S.fxPure Nothing + classDecl = S.Class NoLoc owner [] [] [S.Decl NoLoc [method]] Nothing + tmod = S.Module mn [] Nothing [S.Decl NoLoc [classDecl]] + nmod = I.NModule [] [(owner, I.NClass [] [] [] Nothing)] Nothing + nameHashes = [nameHash owner "src" "pub" "impl"] + withSession = InterfaceFiles.withInterfaceReadSession tyPath + InterfaceFiles.keyReachMember topKey (InterfaceRows.Method member) + `shouldNotBe` InterfaceFiles.keyReachMember topKey (InterfaceRows.Attr member) + InterfaceFiles.keyReachSlot topKey (ReachRows.MethodRef member) + `shouldNotBe` InterfaceFiles.keyReachSlot topKey (ReachRows.AttrRef member) + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod (moduleRows tmod)) + { InterfaceFiles.ifcNameHashes = nameHashes + , InterfaceFiles.ifcReachabilityRows = reachRows + } + withSession $ \session -> do + InterfaceFiles.readInterfaceSessionReachSummaries session mn + `shouldReturn` (summary,summary <> summary) + InterfaceFiles.readInterfaceSessionReachTop session topKey + `shouldReturn` topInfo + InterfaceFiles.readInterfaceSessionReachMemberMaybe session topKey memberKey + `shouldReturn` Just memberInfo + InterfaceFiles.readInterfaceSessionReachShapeMaybe session topKey + `shouldReturn` Just shapeInfo + InterfaceFiles.readInterfaceSessionReachSlotMaybe session topKey memberRef + `shouldReturn` Just slotInfo + InterfaceFiles.readInterfaceSessionReachSlots session topKey + `shouldReturn` [(memberRef,slotInfo)] + InterfaceFiles.readInterfaceSessionReachReflectionMaybe session topKey + `shouldReturn` Just reflection + InterfaceFiles.readInterfaceSessionReachTopMaybe session missingTop + `shouldReturn` Nothing + InterfaceFiles.readInterfaceSessionReachMemberMaybe + session topKey (InterfaceRows.Attr member) `shouldReturn` Nothing + InterfaceFiles.readInterfaceSessionReachShapeMaybe session missingTop + `shouldReturn` Nothing + InterfaceFiles.readInterfaceSessionReachSlotMaybe + session topKey (ReachRows.AttrRef member) `shouldReturn` Nothing + InterfaceFiles.readInterfaceSessionReachReflectionMaybe session missingTop + `shouldReturn` Nothing + InterfaceFiles.readReachabilityRows tyPath mn Nothing `shouldReturn` reachRows + InterfaceFiles.readReachabilityRows tyPath mn (Just owner) `shouldReturn` reachRows + let printed = ReachabilityPrinter.prettyRows mn (Just owner) reachRows + printed `shouldSatisfy` isInfixOf "class Payload" + printed `shouldSatisfy` + isInfixOf "direct dependency.Other.attr field" + InterfaceFiles.updateSourceHashAndNameHashes tyPath "src-2" [] nameHashes + (_sourceMeta, sourceHash, _pubHash, _implHash, _imports, + _depModules, _storedNameHashes, _roots, _tests, _doc) <- + InterfaceFiles.readHeader tyPath + sourceHash `shouldBe` "src-2" + withSession $ \session -> + InterfaceFiles.readInterfaceSessionReachSlotMaybe session topKey memberRef + `shouldReturn` Just slotInfo + InterfaceFiles.updateVersion tyPath S.version + withSession $ \session -> + InterfaceFiles.readInterfaceSessionReachReflectionMaybe session topKey + `shouldReturn` Just reflection + it "reads module query indexes independently" $ do withSystemTempDirectory "acton-iface-indexes" $ \dir -> do let mn = S.modName ["iface_indexes"] @@ -311,7 +872,7 @@ main = do nmod = I.NModule [] iface Nothing tmod = S.Module mn [] Nothing [] names = sort . map fst - InterfaceFiles.writeFile tyPath "src" "pub" "impl" Nothing [] [] [] [] [] Nothing nmod tmod + InterfaceFiles.writeFile (\_ -> return ()) tyPath (interfaceContents nmod (moduleRows tmod)) db <- InterfaceFiles.openInterfaceDB tyPath (do InterfaceFiles.readInterfaceDBNameInfoMaybe db clsName `shouldReturn` Just (clsName, I.NClass [] [] [(classAttr, I.NVar S.tWild)] Nothing) InterfaceFiles.readInterfaceDBNameInfoMaybe db (S.name "missing") `shouldReturn` Nothing @@ -327,12 +888,34 @@ main = do names <$> InterfaceFiles.readInterfaceDBExtByType db (S.NoQ clsName) `shouldReturn` [extName] fst <$> InterfaceFiles.readInterfaceDBModuleInfo db `shouldReturn` []) + it "keeps query indexes exact for structurally distinct names" $ do + withSystemTempDirectory "acton-iface-exact-indexes" $ \dir -> do + let mn = S.modName ["iface_exact_indexes"] + tyPath = dir "iface_exact_indexes.tydb" + plainAttr = S.name "ownerD_part" + derivedAttr = S.Derived (S.name "owner") (S.name "part") + plainOwner = S.name "PlainOwner" + derivedOwner = S.name "DerivedOwner" + iface = + [ (plainOwner,I.NClass [] [] [(plainAttr,I.NVar S.tWild)] Nothing) + , (derivedOwner,I.NClass [] [] [(derivedAttr,I.NVar S.tWild)] Nothing) + ] + nmod = I.NModule [] iface Nothing + tmod = S.Module mn [] Nothing [] + names = map fst + InterfaceFiles.writeFile (\_ -> return ()) tyPath (interfaceContents nmod (moduleRows tmod)) + db <- InterfaceFiles.openInterfaceDB tyPath + names <$> InterfaceFiles.readInterfaceDBConAttr db plainAttr + `shouldReturn` [plainOwner] + names <$> InterfaceFiles.readInterfaceDBConAttr db derivedAttr + `shouldReturn` [derivedOwner] + it "keeps lock files free of named-semaphore state" $ do withSystemTempDirectory "acton-iface-lockfmt" $ \dir -> do let tyPath = dir "lockfmt.tydb" nmod = I.NModule [] [] Nothing tmod = S.Module (S.modName ["lockfmt"]) [] Nothing [] - InterfaceFiles.writeFile tyPath "src" "pub" "impl" Nothing [] [] [] [] [] Nothing nmod tmod + InterfaceFiles.writeFile (\_ -> return ()) tyPath (interfaceContents nmod (moduleRows tmod)) -- liblmdb's lock table must use process-shared mutexes, which live -- inside lock.mdb, on every platform. Its POSIX-semaphore variant -- (upstream's default on macOS) stores "/MDB[rw]..." names here @@ -349,7 +932,9 @@ main = do tyPath = dir "iface_rewrite.tydb" vName = S.name "v" wName = S.name "w" - write iface = InterfaceFiles.writeFile tyPath "src" "pub" "impl" Nothing [] [] [] [] [] Nothing (I.NModule [] iface Nothing) (S.Module mn [] Nothing []) + write iface = InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + interfaceContents (I.NModule [] iface Nothing) + (moduleRows $ S.Module mn [] Nothing []) write [(vName, I.NVar S.tWild)] db <- InterfaceFiles.openInterfaceDB tyPath fmap fst <$> InterfaceFiles.readInterfaceDBNameInfoMaybe db vName `shouldReturn` Just vName @@ -359,30 +944,332 @@ main = do InterfaceFiles.readInterfaceDBNameInfoMaybe db vName `shouldReturn` Nothing fmap fst <$> InterfaceFiles.readInterfaceDBNameInfoMaybe db wName `shouldReturn` Just wName - it "reads selected statements by ownership" $ do - withSystemTempDirectory "acton-iface-stmts" $ \dir -> do - let mn = S.modName ["iface_stmts"] - tyPath = dir "iface_stmts.tydb" - aName = S.name "a" - bName = S.name "b" - cName = S.name "c" - stmtFor n v = S.Assign NoLoc [S.pVar' n] (S.eInt v) - body = [stmtFor aName 1, stmtFor bName 2, stmtFor cName 3] - iface = [ (n, I.NVar S.tWild) | n <- [aName, bName, cName] ] - nameHashes0 = [ nameHash n "s" "p" "i" | n <- [aName, bName, cName] ] - nmod = I.NModule [] iface Nothing - tmod = S.Module mn [] Nothing body - InterfaceFiles.writeFile tyPath "src" "pub" "impl" Nothing [] [] nameHashes0 [] [] Nothing nmod tmod - (_sourceMetaH, _srcH, _pubH, _implH, _impsH, _depModulesH, nameHashesH, _rootsH, _testsH, _docH) <- - InterfaceFiles.readHeader tyPath - [ InterfaceFiles.nhStmtIndices nh | nh <- nameHashesH, InterfaceFiles.nhName nh == bName ] - `shouldBe` [[1]] - selected <- InterfaceFiles.readSelectedModule tyPath nameHashesH (Set.fromList [aName, cName]) - case selected of - Just (S.Module _ _ _ stmts) -> stmts `shouldBe` [stmtFor aName 1, stmtFor cName 3] - Nothing -> expectationFailure "expected selected statements" - missing <- InterfaceFiles.readSelectedModule tyPath nameHashesH (Set.fromList [S.name "nope"]) - missing `shouldBe` Nothing + it "does not load unused top or member content rows" $ do + withSystemTempDirectory "acton-iface-exact-selection-reads" $ \dir -> do + let mn = S.modName ["iface_exact_selection_reads"] + selected = S.name "Selected" + unused = S.name "Unused" + keep = S.name "keep" + drop = S.name "drop" + self = S.name "self" + method name value = S.Def NoLoc name [] + (S.PosPar self (Just S.tSelf) Nothing S.PosNIL) S.KwdNIL + (Just Builtin.tInt) + [S.Return NoLoc $ Just $ S.Int NoLoc value (show value)] + S.NoDec S.fxPure Nothing + selectedDecl = S.Class NoLoc selected [] [] + [S.Decl NoLoc [method keep 1,method drop 2]] Nothing + unusedDecl = S.Class NoLoc unused [] [] + [S.Decl NoLoc [method keep 3]] Nothing + tmod = S.Module mn [] Nothing + [S.Decl NoLoc [selectedDecl,unusedDecl]] + rows = moduleRows tmod + nmod = I.NModule [] + [ (selected,I.NClass [] [] [] Nothing) + , (unused,I.NClass [] [] [] Nothing) + ] Nothing + tyPath = dir "iface_exact_selection_reads.tydb" + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod rows) + { InterfaceFiles.ifcNameHashes = + [ nameHash selected "src-selected" "pub-selected" "impl-selected" + , nameHash unused "src-unused" "pub-unused" "impl-unused" + ] + } + deleteInterfaceEntry tyPath (InterfaceFiles.keyContainerShape unused) + deleteInterfaceEntry tyPath + (InterfaceFiles.keyMemberBody selected $ InterfaceRows.Method drop) + hashes <- InterfaceFiles.readNameHashes tyPath + projected <- withInterfaceSession tyPath $ \session -> + InterfaceFiles.readInterfaceSessionSelection session hashes + (Set.singleton selected) + (M.singleton selected $ Set.singleton $ InterfaceRows.Method keep) + case projected of + S.Module _ _ _ [S.Decl _ [S.Class _ name _ _ body _]] -> do + name `shouldBe` selected + let declarations = + [ S.dname decl + | S.Decl _ decls <- body + , decl <- decls + ] + declarations `shouldBe` [keep,drop] + other -> expectationFailure ("unexpected exact projection: " ++ show other) + deleteInterfaceEntry tyPath + (InterfaceFiles.keyMemberBody selected $ InterfaceRows.Method keep) + missing <- E.try + (withInterfaceSession tyPath $ \session -> + InterfaceFiles.readInterfaceSessionSelection session hashes + (Set.singleton selected) + (M.singleton selected $ Set.singleton $ InterfaceRows.Method keep)) + :: IO (Either E.SomeException S.Module) + case missing of + Left _ -> return () + Right fallback -> expectationFailure + ("missing selected content produced a fallback projection: " ++ show fallback) + + it "bounds composite member keys for long generated names" $ do + withSystemTempDirectory "acton-iface-long-member" $ \dir -> do + let mn = S.modName ["iface_long_member"] + tyPath = dir "iface_long_member.tydb" + owner = S.name (replicate 400 'o') + member = S.name (replicate 400 'm') + self = S.name "self" + methodDef = S.Def NoLoc member [] + (S.PosPar self Nothing Nothing S.PosNIL) S.KwdNIL Nothing + [S.Return NoLoc Nothing] S.NoDec S.fxPure Nothing + classDecl = S.Class NoLoc owner [] [] [S.Decl NoLoc [methodDef]] Nothing + tmod = S.Module mn [] Nothing [S.Decl NoLoc [classDecl]] + rows = moduleRows tmod + nmod = I.NModule [] [] Nothing + nameHashes = [nameHash owner "src" "pub" "impl"] + shapeKey = InterfaceFiles.keyContainerShape owner + memberKey = InterfaceFiles.keyMemberBody owner (InterfaceRows.Method member) + B8.length shapeKey `shouldSatisfy` (<= 511) + B8.length memberKey `shouldSatisfy` (<= 511) + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod rows) + { InterfaceFiles.ifcNameHashes = nameHashes } + InterfaceFiles.readMemberContent tyPath owner (InterfaceRows.Method member) + >>= (`shouldSatisfy` ((== [[S.Return NoLoc Nothing]]) . methodBodies)) + + it "bounds composite dependency-name keys" $ do + withSystemTempDirectory "acton-iface-long-dependency" $ \dir -> do + let mn = S.modName ["iface_long_dependency"] + tyPath = dir "iface_long_dependency.tydb" + owner = S.name "owner" + depModule = S.modName [replicate 400 'm'] + depName = S.name (replicate 400 'n') + ownerHash = (nameHash owner "src" "pub" "impl") + { InterfaceFiles.nhPubDeps = [(S.GName depModule depName,"dep-pub")] + } + depInfo = InterfaceFiles.DepModuleInfo depModule "module-pub" "module-impl" + nmod = I.NModule [] [(owner,I.NVar S.tWild)] Nothing + rows = moduleRows (S.Module mn [] Nothing []) + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod rows) + { InterfaceFiles.ifcDependencies = [depInfo] + , InterfaceFiles.ifcNameHashes = [ownerHash] + } + users <- InterfaceFiles.readDepUsers tyPath depModule depName + InterfaceFiles.duPubUsers users `shouldBe` [owner] + + it "distinguishes plain and derived names with the same symbol spelling" $ do + withSystemTempDirectory "acton-iface-name-keys" $ \dir -> do + let mn = S.modName ["iface_name_keys"] + tyPath = dir "iface_name_keys.tydb" + plain = S.name "ownerD_part" + derived = S.Derived (S.name "owner") (S.name "part") + nmod = I.NModule [] + [(plain,I.NVar S.tWild),(derived,I.NVar S.tWild)] Nothing + nameHashes = + [ nameHash plain "src-plain" "pub-plain" "impl-plain" + , nameHash derived "src-derived" "pub-derived" "impl-derived" + ] + rows = moduleRows (S.Module mn [] Nothing []) + InterfaceFiles.keyNameInfo plain + `shouldNotBe` InterfaceFiles.keyNameInfo derived + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod rows) + { InterfaceFiles.ifcNameHashes = nameHashes } + db <- InterfaceFiles.openInterfaceDB tyPath + InterfaceFiles.readInterfaceDBNameInfoMaybe db plain + `shouldReturn` Just (plain,I.NVar S.tWild) + InterfaceFiles.readInterfaceDBNameInfoMaybe db derived + `shouldReturn` Just (derived,I.NVar S.tWild) + + it "distinguishes container shapes whose names have the same symbol spelling" $ do + withSystemTempDirectory "acton-iface-shape-keys" $ \dir -> do + let mn = S.modName ["iface_shape_keys"] + tyPath = dir "iface_shape_keys.tydb" + plain = S.name "ownerD_part" + derived = S.Derived (S.name "owner") (S.name "part") + classDecl name = S.Class NoLoc name [] [] [] Nothing + tmod = S.Module mn [] Nothing + [S.Decl NoLoc [classDecl plain, classDecl derived]] + rows = moduleRows tmod + nmod = I.NModule [] [] Nothing + nameHashes = + [ nameHash plain "src-plain" "pub-plain" "impl-plain" + , nameHash derived "src-derived" "pub-derived" "impl-derived" + ] + InterfaceFiles.keyContainerShape plain + `shouldNotBe` InterfaceFiles.keyContainerShape derived + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod rows) + { InterfaceFiles.ifcNameHashes = nameHashes } + (_mods, _nmod, restored, _sourceMeta, _srcHash, _pubHash, _implHash, + _imps, _depModules, _storedHashes, _roots, _tests, _doc) <- + InterfaceFiles.readFile tyPath + restored `shouldBe` tmod + + it "partitions final typed generic constructor calls" $ do + let parentSource = unlines + [ "class Base[T]:" + , " x: T" + , " def __init__(self, value: T):" + , " self.x = value" + , "" + , "class Child[T](Base[T]):" + , " y: T" + , " def __init__(self, value: T):" + , " Base.__init__(self, value)" + , " self.y = value" + ] + nativeSource = unlines + [ "class Native(object):" + , " y: int" + , " def __init__(self):" + , " self.setup(1)" + , " self.y = 2" + , " def setup[T](self, value: T) -> None:" + , " NotImplemented" + ] + selectedAttr owner attr rows = + [ initBodyEntries content + | (owner', InterfaceRows.InstanceInit attr', content) <- rowMemberEntries rows + , owner' == owner + , attr' == attr + ] + parentTyped <- typecheckSource env0 "typed_parent_init_rows" parentSource + nativeTyped <- typecheckSource env0 "typed_native_init_rows" nativeSource + selectedAttr (S.name "Child") (S.name "y") (moduleRows parentTyped) + `shouldSatisfy` (not . null) + selectedAttr (S.name "Native") (S.name "y") (moduleRows nativeTyped) + `shouldSatisfy` (not . null) + + it "keeps augmented attribute initialization in the declarative prefix" $ do + let source = unlines + [ "class Payload(object):" + , " value: int" + , " def __init__(self):" + , " self.value = 1" + , " self.value += 2" + ] + owner = S.name "Payload" + attr = S.name "value" + typed <- typecheckSource env0 "typed_augmented_init_rows" source + let rows = moduleRows typed + initBodies = + [ map snd (initBodyEntries content) + | (owner', InterfaceRows.InstanceInit attr', content) <- rowMemberEntries rows + , owner' == owner + , attr' == attr + ] + restBodies = + [ map snd (initBodyEntries content) + | (owner', InterfaceRows.InitRest, content) <- rowMemberEntries rows + , owner' == owner + ] + isAugment (S.MutAssign _ _ (S.Call _ (S.Dot _ _ name) _ _)) = + name == Builtin.iaddKW + isAugment _ = False + initBodies `shouldSatisfy` \bodies -> + case bodies of + [body] -> any isAugment body + _ -> False + concat restBodies `shouldSatisfy` (not . any isAugment) + + it "loads attribute declarations without sibling or initializer rows" $ do + let source = unlines + [ "class Pair(object):" + , " first, second: int" + , " def __init__(self):" + , " self.first = 1" + , " self.second = 2" + ] + typed <- typecheckSource env0 "iface_exact_attr_rows" source + withSystemTempDirectory "acton-iface-exact-attr-rows" $ \dir -> do + let tyPath = dir "iface_exact_attr_rows.tydb" + rows = moduleRows typed + owner = head [ name | name <- M.keys (InterfaceRows.rowShapes rows) + , S.rawstr name == "Pair" ] + attrs = [ name | (_,InterfaceRows.Attr name,_) <- rowMemberEntries rows ] + first = head [ name | name <- attrs, S.rawstr name == "first" ] + second = head [ name | name <- attrs, S.rawstr name == "second" ] + nmod = I.NModule [] [(owner,I.NClass [] [] [] Nothing)] Nothing + hashes = [nameHash owner "src" "pub" "impl"] + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod rows) + { InterfaceFiles.ifcNameHashes = hashes } + forM_ + [ InterfaceRows.Attr second + , InterfaceRows.InstanceInit first + , InterfaceRows.InstanceInit second + ] $ \member -> + deleteInterfaceEntry tyPath (InterfaceFiles.keyMemberBody owner member) + storedHashes <- InterfaceFiles.readNameHashes tyPath + projected <- withInterfaceSession tyPath $ \session -> + InterfaceFiles.readInterfaceSessionSelection session storedHashes + (Set.singleton owner) + (M.singleton owner $ Set.singleton $ InterfaceRows.Attr first) + let propertyNames = + [ names + | S.Module _ _ _ [S.Decl _ [S.Class _ _ _ _ body _]] <- [projected] + , S.Signature _ names _ S.Property <- body + ] + propertyNames `shouldBe` [[first]] + missing <- E.try + (withInterfaceSession tyPath $ \session -> + InterfaceFiles.readInterfaceSessionSelection session storedHashes + (Set.singleton owner) + (M.singleton owner $ Set.fromList + [InterfaceRows.Attr first,InterfaceRows.InstanceInit first])) + :: IO (Either E.SomeException S.Module) + case missing of + Left _ -> return () + Right fallback -> expectationFailure + ("missing selected initializer produced a fallback projection: " ++ show fallback) + + it "keeps conditional attribute initializer rows branch-exact" $ do + let source = unlines + [ "def choose() -> bool:" + , " return True" + , "" + , "def first_value() -> int:" + , " return 1" + , "" + , "def second_value() -> int:" + , " return 2" + , "" + , "actor Pair():" + , " first = 0" + , " second = 0" + , " if choose():" + , " first = first_value()" + , " else:" + , " second = second_value()" + ] + typed <- typecheckSource env0 "iface_conditional_attr_rows" source + withSystemTempDirectory "acton-iface-conditional-attr-rows" $ \dir -> do + let tyPath = dir "iface_conditional_attr_rows.tydb" + rows = moduleRows typed + owner = head [ name | name <- M.keys (InterfaceRows.rowShapes rows) + , S.rawstr name == "Pair" ] + attrs = [ name | (_,InterfaceRows.Attr name,_) <- rowMemberEntries rows ] + first = head [ name | name <- attrs, S.rawstr name == "first" ] + second = head [ name | name <- attrs, S.rawstr name == "second" ] + nmod = I.NModule [] [(owner,I.NAct [] S.posNil S.kwdNil [] Nothing)] Nothing + hashes = + [ nameHash name "src" "pub" "impl" + | name <- concatMap InterfaceRows.storedStmtNames + (InterfaceRows.rowStatements rows) + ] + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod rows) + { InterfaceFiles.ifcNameHashes = hashes } + deleteInterfaceEntry tyPath + (InterfaceFiles.keyMemberBody owner $ InterfaceRows.InstanceInit second) + storedHashes <- InterfaceFiles.readNameHashes tyPath + projected <- withInterfaceSession tyPath $ \session -> + InterfaceFiles.readInterfaceSessionSelection session storedHashes + (Set.singleton owner) + (M.singleton owner $ Set.fromList + [InterfaceRows.Attr first,InterfaceRows.InstanceInit first]) + let S.Module _ _ _ body = projected + free = map S.rawstr (Names.free body) + free `shouldSatisfy` elem "choose" + free `shouldSatisfy` elem "first_value" + free `shouldSatisfy` not . elem "second_value" it "supports concurrent read-only access to one interface" $ do withSystemTempDirectory "acton-iface-concurrent" $ \dir -> do @@ -393,7 +1280,9 @@ main = do nameHashes = [nameHash firstName "src1" "pub1" "impl1"] nmod = I.NModule [] iface Nothing tmod = S.Module mn [] Nothing [] - InterfaceFiles.writeFile tyPath "src" "pub" "impl" Nothing [] [] nameHashes [] [] Nothing nmod tmod + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod (moduleRows tmod)) + { InterfaceFiles.ifcNameHashes = nameHashes } mapConcurrently_ (\_ -> do (_sourceMetaH, srcHashH, pubHashH, implHashH, _impsH, _depModulesH, nameHashesH, _rootsH, _testsH, _docH) <- @@ -412,7 +1301,9 @@ main = do nameHashes = [nameHash firstName "src1" "pub1" "impl1"] nmod = I.NModule [] iface Nothing tmod = S.Module mn [] Nothing [] - InterfaceFiles.writeFile srcPath "src" "pub" "impl" Nothing [] [] nameHashes [] [] Nothing nmod tmod + InterfaceFiles.writeFile (\_ -> return ()) srcPath $ + (interfaceContents nmod (moduleRows tmod)) + { InterfaceFiles.ifcNameHashes = nameHashes } InterfaceFiles.copyInterface srcPath dstPath doesFileExist (dstPath "data.mdb") `shouldReturn` True doesFileExist (dstPath "lock.mdb") `shouldReturn` False @@ -432,7 +1323,9 @@ main = do nameHashes = [nameHash firstName "src1" "pub1" "impl1"] nmod = I.NModule [] iface Nothing tmod = S.Module mn [] Nothing [] - InterfaceFiles.writeFile tyPath "src" "pub" "impl" Nothing [] [] nameHashes [] [] Nothing nmod tmod + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod (moduleRows tmod)) + { InterfaceFiles.ifcNameHashes = nameHashes } removeFile lockPath InterfaceFiles.registerSystemTypeRoots [typesRoot] (_sourceMetaH, srcHashH, pubHashH, implHashH, _impsH, _depModulesH, nameHashesH, _rootsH, _testsH, _docH) <- @@ -461,11 +1354,150 @@ main = do tyPath = dir "iface_version.tydb" nmod = I.NModule [] [] Nothing tmod = S.Module mn [] Nothing [] - InterfaceFiles.writeFileWithVersion (map (+ 1) S.version) tyPath "" "" "" Nothing [] [] [] [] [] Nothing nmod tmod + InterfaceFiles.writeVersionedFile (map (+ 1) S.version) tyPath $ + (interfaceContents nmod (moduleRows tmod)) + { InterfaceFiles.ifcSourceHash = "" + , InterfaceFiles.ifcPublicHash = "" + , InterfaceFiles.ifcImplementationHash = "" + } InterfaceFiles.readHeaderMaybe tyPath `shouldReturn` Nothing InterfaceFiles.readFileMaybe tyPath `shouldReturn` Nothing + it "treats missing required current-version rows as cache misses" $ do + withSystemTempDirectory "acton-iface-required-rows" $ \dir -> do + let mn = S.modName ["iface_required_rows"] + nmod = I.NModule [] [] Nothing + tmod = S.Module mn [] Nothing [] + rows = moduleRows tmod + checkMissing entry = do + let tyPath = dir (B8.unpack entry ++ ".tydb") + InterfaceFiles.writeFile (\_ -> return ()) tyPath $ + (interfaceContents nmod rows) + { InterfaceFiles.ifcSourceHash = "" + , InterfaceFiles.ifcPublicHash = "" + , InterfaceFiles.ifcImplementationHash = "" + } + deleteInterfaceEntry tyPath entry + InterfaceFiles.readHeaderMaybe tyPath `shouldReturn` Nothing + InterfaceFiles.readFileMaybe tyPath `shouldReturn` Nothing + checkMissing "stmt-has-not-impl" + checkMissing "stmt-mandatory" + checkMissing "module-hash" + + describe "Reachability selection" $ do + let mn = S.modName ["selection"] + top name = ReachRows.TopKey mn (S.name name) + a = top "A" + b = top "B" + c = top "C" + d = top "D" + run = S.name "run" + method owner name = + ( ReachRows.MethodRef name + , ReachRows.SlotInfo owner $ ReachRows.StoredSlot $ InterfaceRows.Method name + ) + attr owner name = + (ReachRows.AttrRef name,ReachRows.SlotInfo owner ReachRows.AttributeSlot) + methodInfo owner name = + (owner,InterfaceRows.Method name,ReachRows.MemberInfo mempty Nothing Nothing) + edge constructor (ReachRows.TopKey moduleName name) = constructor moduleName name + selected index edges = case selectFixture index edges of + Left err -> expectationFailure ("selection failed: " ++ show err) >> return Reachability.emptySelection + Right result -> return result + + it "keeps same-named methods on unrelated classes separate" $ do + let index = selectionIndex + [ selectionClass a [a] [method a run] + , selectionClass b [b] [method b run] + ] + [methodInfo a run,methodInfo b run] + [] + result <- selected index + [ edge (\moduleName name -> ReachRows.Dispatch moduleName name $ ReachRows.MethodRef run) a + , edge ReachRows.Construct a + ] + Set.member (a,InterfaceRows.Method run) (Reachability.selectedMembers result) + `shouldBe` True + Set.member (b,InterfaceRows.Method run) (Reachability.selectedMembers result) + `shouldBe` False + + it "is independent of dispatch and construction discovery order" $ do + let index = selectionIndex + [ selectionClass b [b] [method b run] + , selectionClass d [d,b] [method d run] + ] + [methodInfo b run,methodInfo d run] + [] + dispatch = edge + (\moduleName name -> ReachRows.Dispatch moduleName name $ ReachRows.MethodRef run) b + construct = edge ReachRows.Construct d + forward <- selected index [dispatch,construct] + backward <- selected index [construct,dispatch] + forward `shouldBe` backward + Set.member (d,InterfaceRows.Method run) (Reachability.selectedMembers forward) + `shouldBe` True + + it "activates the exact instance initializer of a used attribute" $ do + let field = S.name "field" + dependency = top "InitializerDependency" + initializer = ReachRows.reachSummaryFromEdges [edge ReachRows.Need dependency] + index = selectionIndex + [selectionClass c [c] [attr c field]] + [(c,InterfaceRows.Attr field,ReachRows.MemberInfo mempty Nothing $ Just initializer)] + [(dependency,mempty)] + result <- selected index + [edge (\moduleName name -> ReachRows.Direct moduleName name $ ReachRows.AttrRef field) c] + Set.member (c,field) (Reachability.selectedInstanceInitializers result) + `shouldBe` True + Set.member dependency (Reachability.selectedTops result) `shouldBe` True + + it "is independent of reflection and construction discovery order" $ do + let field = S.name "field" + index = selectionIndex + [ selectionClass b [b] [attr b field] + , selectionClass d [d,b] [attr b field] + ] + [(b,InterfaceRows.Attr field,ReachRows.MemberInfo mempty Nothing Nothing)] + [] + reflect = edge ReachRows.Reflect b + construct = edge ReachRows.Construct d + forward <- selected index [reflect,construct] + backward <- selected index [construct,reflect] + forward `shouldBe` backward + Set.member (b,field) (Reachability.selectedAttrs forward) `shouldBe` True + + it "reads every reached row once and no unused rows" $ do + let unused = S.name "unused" + index = selectionIndex + [selectionClass c [c] [method c run,attr c unused]] + [ methodInfo c run + , (c,InterfaceRows.Attr unused,ReachRows.MemberInfo mempty Nothing Nothing) + ] + [] + direct = edge + (\moduleName name -> ReachRows.Direct moduleName name $ ReachRows.MethodRef run) c + (outcome,counts) = St.runState + (Reachability.selectProgram (countedSelectionLookup index) $ replicate 3 direct) + emptySelectionCounts + case outcome of + Left err -> expectationFailure ("selection failed: " ++ show err) + Right _ -> return () + countTops counts `shouldBe` M.singleton c 1 + countMembers counts `shouldBe` M.singleton (c,InterfaceRows.Method run) 1 + countSlots counts `shouldBe` M.singleton (c,ReachRows.MethodRef run) 1 + countShapes counts `shouldBe` M.empty + countSurfaces counts `shouldBe` M.empty + countReflections counts `shouldBe` M.empty + describe "Hashing" $ do + it "binds generated output to compiler identity and line mode" $ do + let impl = B8.pack "impl" + source = B8.pack "source" + withLines = Hashing.wholeCodegenHash True impl source + withoutLines = Hashing.wholeCodegenHash False impl source + Hashing.codegenIdentity `shouldSatisfy` (not . B8.null) + withLines `shouldNotBe` withoutLines + it "keeps public hashes independent of docs and source locations" $ do let infoA = I.NDef (S.TSchema (Loc 1 3) [] (locatedType (Loc 4 5))) S.NoDec (Just "old docs") infoB = I.NDef (S.TSchema (Loc 50 60) [] (locatedType (Loc 70 80))) S.NoDec (Just "new docs") @@ -638,6 +1670,40 @@ main = do Hashing.computeHashes selfHashes M.empty extDepsA `shouldBe` Hashing.computeHashes selfHashes M.empty extDepsB + it "hashes ownerless statements and their final local implementations" $ do + let stmt value = S.Expr NoLoc (S.Int NoLoc value (show value)) + moduleHash statements implHashes localDeps = + Hashing.finishModuleHash implHashes + (Hashing.moduleOwnImplHash [] statements) + (replicate (length statements) []) localDeps [] [] + ownerlessA = moduleHash [stmt 1] M.empty [] + ownerlessB = moduleHash [stmt 2] M.empty [] + aggregate info = Hashing.moduleImplHashFromNameHashes info [] + local = S.name "local_value" + localStmt = S.Expr NoLoc (S.Var NoLoc (S.NoQ local)) + localA = moduleHash [localStmt] (M.singleton local "impl-1") [local] + localB = moduleHash [localStmt] (M.singleton local "impl-2") [local] + aggregate ownerlessA `shouldNotBe` aggregate ownerlessB + InterfaceFiles.mhImplHash localA `shouldNotBe` + InterfaceFiles.mhImplHash localB + + it "preserves initialization order across independently hashed names" $ do + let a = S.name "a" + b = S.name "b" + implHashes = M.fromList [(a,"a-impl"),(b,"b-impl")] + moduleHash owners = Hashing.finishModuleHash + implHashes (Hashing.moduleOwnImplHash [] []) owners [] [] [] + InterfaceFiles.mhImplHash (moduleHash [[a],[b]]) `shouldNotBe` + InterfaceFiles.mhImplHash (moduleHash [[b],[a]]) + + it "preserves source import order in the module implementation hash" $ do + let a = S.modName ["a"] + b = S.modName ["b"] + moduleHash imports = Hashing.finishModuleHash M.empty + (Hashing.moduleOwnImplHash imports []) [] [] [] [] + InterfaceFiles.mhImplHash (moduleHash [a,b]) `shouldNotBe` + InterfaceFiles.mhImplHash (moduleHash [b,a]) + it "hashes module summaries from maps like assembled name hashes" $ do let publicName = S.name "public_value" privateName = S.name "__private_value" @@ -657,9 +1723,9 @@ main = do , nameHash privateName "src-private" "pub-private" "impl-private" , nameHash missingImplName "src-missing" "pub-missing" "" ] - Hashing.moduleHashesFromHashMaps nmod nameKeys pubHashes implHashes `shouldBe` + Hashing.moduleHashesFromHashMaps nmod InterfaceFiles.emptyModuleHashInfo nameKeys pubHashes implHashes `shouldBe` ( Hashing.modulePubHashFromIface nmod nameHashes - , Hashing.moduleImplHashFromNameHashes nameHashes + , Hashing.moduleImplHashFromNameHashes InterfaceFiles.emptyModuleHashInfo nameHashes ) it "hashes public interface names outside implementation keys" $ do @@ -676,7 +1742,7 @@ main = do pubHashes = M.fromList [(publicName, "pub-public"), (ifaceOnlyName, "pub-iface-only")] implHashes = M.singleton publicName "impl-public" (modulePubHash, moduleImplHash) = - Hashing.moduleHashesFromHashMaps nmod nameKeys pubHashes implHashes + Hashing.moduleHashesFromHashMaps nmod InterfaceFiles.emptyModuleHashInfo nameKeys pubHashes implHashes publicNameHashes = [ nameHash publicName "src-public" "pub-public" "impl-public" , nameHash ifaceOnlyName "" "pub-iface-only" "" @@ -686,7 +1752,8 @@ main = do modulePubHash `shouldBe` Hashing.modulePubHashFromIface nmod publicNameHashes modulePubHash `shouldNotBe` Hashing.modulePubHashFromIface nmod implNameHashes - moduleImplHash `shouldBe` Hashing.moduleImplHashFromNameHashes implNameHashes + moduleImplHash `shouldBe` + Hashing.moduleImplHashFromNameHashes InterfaceFiles.emptyModuleHashInfo implNameHashes it "merges canonical dependency lists without rebuilding sets" $ do let a = S.name "a" @@ -851,6 +1918,18 @@ main = do snd (Hashing.implSplitDepsFromItems mn env localNames items) `shouldBe` M.singleton value [] + it "keeps the knot-tied current witness out of impl dependencies" $ do + let value = hashTestName + mn = S.modName ["hash_witness_self"] + target = S.GName (S.modName ["dep"]) (S.name "Target") + env = Acton.Env.setMod mn env0 + decl = S.Extension NoLoc [] (S.TC target []) [] + [S.Expr NoLoc $ S.Var NoLoc $ S.NoQ Names.selfKW'] Nothing + items = [Hashing.TLDecl value decl] + localNames = Set.singleton value + snd (Hashing.implSplitDepsFromItems mn env localNames items) `shouldBe` + M.singleton value [target] + it "keeps enclosing bindings across nested declarations" $ do let value = hashTestName inner = S.name "inner" @@ -893,17 +1972,110 @@ main = do M.singleton value [] describe "CompileScheduler" $ do - it "waits for canceled generation cleanup before launching the replacement" $ do - let gopts = C.GlobalOptions - { C.color = C.Never - , C.quiet = True - , C.noProgress = False - , C.timing = False - , C.tty = False - , C.verbose = False - , C.verboseZig = False - , C.jobs = 1 + let gopts = C.GlobalOptions + { C.color = C.Never + , C.quiet = True + , C.noProgress = False + , C.timing = False + , C.tty = False + , C.verbose = False + , C.verboseZig = False + , C.jobs = 1 + } + backJob dir mn = + let out = dir "out" + types = out "types" + paths = Compile.Paths + { Compile.searchPath = [] + , Compile.sysPath = "" + , Compile.sysTypes = "" + , Compile.projPath = dir + , Compile.projOut = out + , Compile.projTypes = types + , Compile.binDir = out "bin" + , Compile.srcDir = dir "src" + , Compile.isTmp = False + , Compile.fileExt = ".act" + , Compile.modName = mn + , Compile.projName = "queue_test" + } + input = Compile.BackInput + { Compile.biTypeEnv = Acton.Env.setMod mn env0 + , Compile.biTypedMod = S.Module mn [] Nothing [] + , Compile.biDeclarations = [] + , Compile.biSrc = Just "" + , Compile.biCodegenHash = B8.replicate 32 '0' + } + in Compile.BackJob paths Compile.defaultCompileOptions input + isBackFailure (Just (Just _)) = True + isBackFailure _ = False + + it "keeps workers alive and drains jobs when callbacks throw" $ do + sched <- Compile.newCompileScheduler gopts 1 + gen1 <- Compile.startCompile sched 0 $ \_ -> return () + firstDone <- newEmptyMVar + let mn1 = S.modName ["callback_failure"] + callbacks1 = Compile.defaultBackJobCallbacks + { Compile.bjcOnStart = \_ -> E.throwIO $ userError "start callback failed" + , Compile.bjcOnDone = \_ _ -> do + putMVar firstDone () + E.throwIO $ userError "done callback failed" } + Compile.backQueueEnqueue (Compile.csBackQueue sched) gen1 + (backJob "." mn1) callbacks1 `shouldReturn` True + timeout 1000000 (Compile.backQueueWait (Compile.csBackQueue sched) gen1) + >>= (`shouldSatisfy` isBackFailure) + timeout 1000000 (takeMVar firstDone) `shouldReturn` Just () + + gen2 <- Compile.startCompile sched 0 $ \_ -> return () + secondStarted <- newEmptyMVar + let mn2 = S.modName ["worker_survived"] + callbacks2 = Compile.defaultBackJobCallbacks + { Compile.bjcOnStart = \_ -> do + putMVar secondStarted () + E.throwIO $ userError "second callback failed" + } + Compile.backQueueEnqueue (Compile.csBackQueue sched) gen2 + (backJob "." mn2) callbacks2 `shouldReturn` True + timeout 1000000 (takeMVar secondStarted) `shouldReturn` Just () + timeout 1000000 (Compile.backQueueWait (Compile.csBackQueue sched) gen2) + >>= (`shouldSatisfy` isBackFailure) + + it "does not start a new generation during a guarded output write" $ do + withSystemTempDirectory "acton-generation-lock" $ \dir -> do + let mn = S.modName ["guarded_write"] + job = backJob dir mn + types = Compile.projTypes (Compile.bjPaths job) + createDirectoryIfMissing True types + sched <- Compile.newCompileScheduler gopts 1 + gen <- Compile.startCompile sched 0 $ \_ -> return () + writeStarted <- newEmptyMVar + releaseWrite <- newEmptyMVar + nextStarted <- newEmptyMVar + let callbacks = Compile.defaultBackJobCallbacks + { Compile.bjcOnProgress = \_ progress -> + case progress of + Compile.BackPassStarted Compile.BackPassWrite _ _ -> do + putMVar writeStarted () + takeMVar releaseWrite + _ -> return () + } + Compile.backQueueEnqueue (Compile.csBackQueue sched) gen job callbacks + `shouldReturn` True + timeout 1000000 (takeMVar writeStarted) `shouldReturn` Just () + nextCompile <- async $ + Compile.startCompile sched 0 $ \_ -> putMVar nextStarted () + E.finally + (timeout 100000 (takeMVar nextStarted) `shouldReturn` Nothing) + (putMVar releaseWrite ()) + nextGen <- wait nextCompile + nextGen `shouldBe` gen + 1 + timeout 1000000 (takeMVar nextStarted) `shouldReturn` Just () + doesFileExist (types "guarded_write.c") `shouldReturn` True + timeout 1000000 (Compile.backQueueWait (Compile.csBackQueue sched) gen) + `shouldReturn` Just Nothing + + it "waits for canceled generation cleanup before launching the replacement" $ do sched <- Compile.newCompileScheduler gopts 1 oldStarted <- newEmptyMVar oldCleanupStarted <- newEmptyMVar @@ -933,37 +2105,33 @@ main = do directIface = I.NModule [] iface Nothing directModule = S.Module directMod [] Nothing [] env1 = Acton.Env.addMod directMod [] iface Nothing env0 - InterfaceFiles.writeFile - directTy - B8.empty - B8.empty - B8.empty - Nothing - [] - [] - [] - [] - [] - Nothing - directIface - directModule + InterfaceFiles.writeFile (\_ -> return ()) directTy $ + (interfaceContents directIface (moduleRows directModule)) + { InterfaceFiles.ifcSourceHash = B8.empty + , InterfaceFiles.ifcPublicHash = B8.empty + , InterfaceFiles.ifcImplementationHash = B8.empty + } (_mods, nmod, tmod, sourceMeta, srcHash, pubHash, implHash, imps, depModules, nameHashes, roots, tests, mdoc) <- InterfaceFiles.readFile directTy - InterfaceFiles.writeFileWithVersion + InterfaceFiles.writeVersionedFile (map (+ 1) S.version) directTy - srcHash - pubHash - implHash - sourceMeta - imps - depModules - nameHashes - roots - tests - mdoc - nmod - tmod + InterfaceFiles.InterfaceContents + { InterfaceFiles.ifcSourceHash = srcHash + , InterfaceFiles.ifcPublicHash = pubHash + , InterfaceFiles.ifcImplementationHash = implHash + , InterfaceFiles.ifcModuleHashInfo = InterfaceFiles.emptyModuleHashInfo + , InterfaceFiles.ifcSourceMeta = sourceMeta + , InterfaceFiles.ifcImports = imps + , InterfaceFiles.ifcDependencies = depModules + , InterfaceFiles.ifcNameHashes = nameHashes + , InterfaceFiles.ifcRoots = roots + , InterfaceFiles.ifcTests = tests + , InterfaceFiles.ifcDoc = mdoc + , InterfaceFiles.ifcModule = nmod + , InterfaceFiles.ifcRows = moduleRows tmod + , InterfaceFiles.ifcReachabilityRows = ReachRows.emptyReachabilityRows + } (_env2, mi) <- Acton.Env.doImp [dir] env1 directMod map fst (Acton.Env.modulePublicTEnv mi) `shouldBe` [valueName] @@ -1345,20 +2513,13 @@ main = do createDirectoryIfMissing True dir createDirectoryIfMissing True staleTy B8.writeFile (staleTy "data.mdb") "not a current ty db" - InterfaceFiles.writeFile - directTy - B8.empty - B8.empty - B8.empty - Nothing - [(staleMod, B8.empty)] - [] - [] - [] - [] - Nothing - directIface - directModule + InterfaceFiles.writeFile (\_ -> return ()) directTy $ + (interfaceContents directIface (moduleRows directModule)) + { InterfaceFiles.ifcSourceHash = B8.empty + , InterfaceFiles.ifcPublicHash = B8.empty + , InterfaceFiles.ifcImplementationHash = B8.empty + , InterfaceFiles.ifcImports = [(staleMod, B8.empty)] + } items <- Completion.memberCompletions env0 [dir] (S.modName ["rfs"]) "rfs.act" src cursor map Completion.completionLabel items `shouldSatisfy` elem "local_field" @@ -3196,7 +4357,7 @@ testCodeGen env0 modulePaths = do let act_file = "test" "src" modulePath ++ ".act" srcText <- readFile act_file let srcbase = "test" "src" modulePath - (n,h,c) <- Acton.CodeGen.generate liftEnv srcbase srcText True boxed "test-hash" + (n,h,c) <- Acton.CodeGen.generate liftEnv [] srcbase srcText True boxed "test-hash" let newAccEnv = Acton.Env.addMod (S.modname parsed) imps tenv mdoc accEnv return (newAccEnv, accModules ++ [(takeFileName modulePath, boxed, n, h, c)]) @@ -3234,7 +4395,7 @@ testCodeGenContains env0 modulePath expected = do let act_file = "test" "src" modulePath ++ ".act" srcText <- readFile act_file let srcbase = "test" "src" modulePath - (_, _, c) <- Acton.CodeGen.generate liftEnv srcbase srcText True boxed "test-hash" + (_, _, c) <- Acton.CodeGen.generate liftEnv [] srcbase srcText True boxed "test-hash" return c describe modulePath $ @@ -3378,6 +4539,285 @@ testDocstrings env0 testname = do testAttributesInitialization :: Acton.Env.Env0 -> Spec testAttributesInitialization env0 = do describe "Class Attribute Initialization Check" $ do + it "exposes the declarative constructor prefix at the self-escape boundary" $ do + let self = S.name "self" + tmp = S.name "tmp" + x = S.name "x" + y = S.name "y" + publish = S.name "publish" + local = S.Assign NoLoc [S.PVar NoLoc tmp Nothing] (S.Int NoLoc 1 "1") + set attr value = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) attr) value + setX = set x (S.Var NoLoc (S.NoQ tmp)) + escape = S.Expr NoLoc $ S.Call NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) publish) + S.PosNil + S.KwdNil + setY = set y (S.Int NoLoc 2 "2") + body = [local, setX, escape, setY] + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] body + attrs `shouldBe` [x] + prefixLength `shouldBe` 2 + + it "counts structured initialization as one top-level constructor statement" $ do + let self = S.name "self" + x = S.name "x" + y = S.name "y" + z = S.name "z" + set attr value = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) attr) value + setX value = set x (S.Int NoLoc value (show value)) + branches = [S.Branch (S.Bool NoLoc True) [setX 1]] + conditional = S.If NoLoc branches [setX 2] + setY = set y (S.Int NoLoc 3 "3") + body = [conditional, setY, S.Return NoLoc Nothing, set z (S.Int NoLoc 4 "4")] + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] body + attrs `shouldBe` [x, y] + prefixLength `shouldBe` 2 + + it "does not cross a self escape nested in a structured statement" $ do + let self = S.name "self" + x = S.name "x" + y = S.name "y" + publish = S.name "publish" + set attr value = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) attr) value + setX value = set x (S.Int NoLoc value (show value)) + escape = S.Expr NoLoc $ S.Call NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) publish) + S.PosNil + S.KwdNil + branches = [S.Branch (S.Bool NoLoc True) [setX 1, escape]] + conditional = S.If NoLoc branches [setX 2] + body = [conditional, set y (S.Int NoLoc 3 "3")] + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] body + attrs `shouldBe` [x] + prefixLength `shouldBe` 0 + + it "does not cross a return nested in a structured statement" $ do + let self = S.name "self" + x = S.name "x" + setX = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) x) + (S.Int NoLoc 1 "1") + branches = [S.Branch (S.Bool NoLoc True) [S.Return NoLoc Nothing]] + conditional = S.If NoLoc branches [S.Pass NoLoc] + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] [conditional, setX] + attrs `shouldBe` [] + prefixLength `shouldBe` 0 + + it "checks branch conditions for constructor-boundary escapes" $ do + let self = S.name "self" + x = S.name "x" + publish = S.name "publish" + condition = S.Call NoLoc (S.Var NoLoc (S.NoQ publish)) + (S.PosArg (S.Var NoLoc (S.NoQ self)) S.PosNil) + S.KwdNil + setX value = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) x) + (S.Int NoLoc value (show value)) + conditional = S.If NoLoc [S.Branch condition [setX 1]] [setX 2] + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] [conditional, setX 3] + attrs `shouldBe` [] + prefixLength `shouldBe` 0 + + it "checks both sides of non-attribute mutations for self escapes" $ do + let self = S.name "self" + sink = S.name "sink" + value = S.name "value" + x = S.name "x" + leak = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ sink)) value) + (S.Var NoLoc (S.NoQ self)) + setX = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) x) + (S.Int NoLoc 1 "1") + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] [leak, setX] + attrs `shouldBe` [] + prefixLength `shouldBe` 0 + + it "does not cross a return nested in a loop" $ do + let self = S.name "self" + x = S.name "x" + loop = S.While NoLoc (S.Bool NoLoc True) [S.Return NoLoc Nothing] [] + setX = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) x) + (S.Int NoLoc 1 "1") + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] [loop, setX] + attrs `shouldBe` [] + prefixLength `shouldBe` 0 + + it "treats raising an exception containing self as a boundary" $ do + let self = S.name "self" + errorName = S.name "Error" + x = S.name "x" + exception = S.Call NoLoc (S.Var NoLoc (S.NoQ errorName)) + (S.PosArg (S.Var NoLoc (S.NoQ self)) S.PosNil) + S.KwdNil + setX = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) x) + (S.Int NoLoc 1 "1") + conditional = S.If NoLoc + [S.Branch (S.Bool NoLoc True) [S.Raise NoLoc exception]] + [S.Pass NoLoc] + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] [conditional, setX] + attrs `shouldBe` [] + prefixLength `shouldBe` 0 + + it "does not let finally initialize an attribute used by try" $ do + let self = S.name "self" + publish = S.name "publish" + x = S.name "x" + y = S.name "y" + selfAttr attr = S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) attr + publishX = S.Expr NoLoc $ S.Call NoLoc + (S.Var NoLoc (S.NoQ publish)) + (S.PosArg (selfAttr x) S.PosNil) + S.KwdNil + set attr value = S.MutAssign NoLoc (selfAttr attr) value + setX = set x (S.Int NoLoc 1 "1") + setY = set y (S.Int NoLoc 2 "2") + guarded = S.Try NoLoc [publishX] [] [] [setX] + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] [guarded, setY] + attrs `shouldBe` [] + prefixLength `shouldBe` 0 + + it "makes completed try assignments visible to its else block" $ do + let self = S.name "self" + x = S.name "x" + y = S.name "y" + selfAttr attr = S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) attr + set attr value = S.MutAssign NoLoc (selfAttr attr) value + setX = set x (S.Int NoLoc 1 "1") + setY = set y (selfAttr x) + guarded = S.Try NoLoc [setX] [] [setY] [] + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] [guarded] + attrs `shouldBe` [x, y] + prefixLength `shouldBe` 1 + + it "looks through typed expression wrappers for self escapes" $ do + let self = S.name "self" + publish = S.name "publish" + x = S.name "x" + wrapped = S.TApp NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) publish) + [S.tWild] + escape = S.Expr NoLoc $ S.Call NoLoc wrapped S.PosNil S.KwdNil + setX = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) x) + (S.Int NoLoc 1 "1") + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] [escape, setX] + attrs `shouldBe` [] + prefixLength `shouldBe` 0 + + it "recognizes typed parent constructor calls in the declarative prefix" $ do + let self = S.name "self" + parent = S.name "Parent" + y = S.name "y" + env = Acton.Env.define [(parent, I.NClass [] [] [] Nothing)] env0 + parentInit = S.Expr NoLoc $ S.Call NoLoc + (S.TApp NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ parent)) Builtin.initKW) + [S.tWild]) + (S.PosArg (S.Var NoLoc (S.NoQ self)) S.PosNil) + S.KwdNil + setY = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) y) + (S.Int NoLoc 1 "1") + (attrs, prefixLength) = + Acton.Types.scanInitPrefix env self [] [parentInit, setY] + attrs `shouldBe` [y] + prefixLength `shouldBe` 2 + + it "recognizes typed NotImplemented self calls in the declarative prefix" $ do + let self = S.name "self" + native = S.name "native" + y = S.name "y" + nativeDef = S.Def NoLoc native [] + (S.PosPar self Nothing Nothing S.PosNIL) S.KwdNIL Nothing + [S.Expr NoLoc (S.NotImplemented NoLoc)] + S.NoDec S.fxPure Nothing + nativeCall = S.Expr NoLoc $ S.Call NoLoc + (S.TApp NoLoc + (S.Dot NoLoc + (S.TApp NoLoc (S.Var NoLoc (S.NoQ self)) [S.tWild]) + native) + [S.tWild]) + S.PosNil S.KwdNil + setY = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) y) + (S.Int NoLoc 1 "1") + (attrs, prefixLength) = Acton.Types.scanInitPrefix + env0 self [S.Decl NoLoc [nativeDef]] [nativeCall, setY] + attrs `shouldBe` [y] + prefixLength `shouldBe` 2 + + it "detects aliased constructor receivers captured by nested actors" $ do + let receiver = S.name "me" + actorName = S.name "Nested" + x = S.name "x" + nested = S.Actor NoLoc actorName [] S.PosNIL S.KwdNIL + [S.Expr NoLoc (S.Var NoLoc (S.NoQ receiver))] Nothing + setX = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ receiver)) x) + (S.Int NoLoc 1 "1") + (attrs, prefixLength) = Acton.Types.scanInitPrefix + env0 receiver [] [S.Decl NoLoc [nested], setX] + attrs `shouldBe` [] + prefixLength `shouldBe` 0 + + it "does not expose try assignments to finally" $ do + let self = S.name "self" + f = S.name "f" + publish = S.name "publish" + x = S.name "x" + selfX = S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) x + setX = S.MutAssign NoLoc selfX $ S.Call NoLoc + (S.Var NoLoc (S.NoQ f)) S.PosNil S.KwdNil + publishX = S.Expr NoLoc $ S.Call NoLoc + (S.Var NoLoc (S.NoQ publish)) (S.PosArg selfX S.PosNil) S.KwdNil + guarded = S.Try NoLoc [setX] [] [] [publishX] + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] [guarded] + attrs `shouldBe` [] + prefixLength `shouldBe` 0 + + it "ignores an unreachable else boundary after an unconditional raise" $ do + let self = S.name "self" + errorName = S.name "Error" + publish = S.name "publish" + x = S.name "x" + raiseError = S.Raise NoLoc $ S.Call NoLoc + (S.Var NoLoc (S.NoQ errorName)) S.PosNil S.KwdNil + escape = S.Expr NoLoc $ S.Call NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) publish) S.PosNil S.KwdNil + setX = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) x) + (S.Int NoLoc 1 "1") + guarded = S.Try NoLoc [raiseError] [] [escape] [] + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] [guarded, setX] + attrs `shouldBe` [x] + prefixLength `shouldBe` 2 + + it "checks nested declaration defaults before parameter shadowing" $ do + let self = S.name "self" + nested = S.name "nested" + x = S.name "x" + declaration = S.Def NoLoc nested [] + (S.PosPar self Nothing (Just (S.Var NoLoc (S.NoQ self))) S.PosNIL) + S.KwdNIL + Nothing + [S.Pass NoLoc] + S.NoDec + S.fxPure + Nothing + setX = S.MutAssign NoLoc + (S.Dot NoLoc (S.Var NoLoc (S.NoQ self)) x) + (S.Int NoLoc 1 "1") + body = [S.Decl NoLoc [declaration], setX] + (attrs, prefixLength) = Acton.Types.scanInitPrefix env0 self [] body + attrs `shouldBe` [] + prefixLength `shouldBe` 0 + testTypeSuccess env0 "class_init_attrs/init_basic" testTypeSuccess env0 "class_init_attrs/init_inferred_only" testTypeError env0 "class_init_attrs/uninit_basic" diff --git a/test/core_lang_auto/get_attr.act b/test/core_lang_auto/get_attr.act index 8a0894873..e51982ebf 100644 --- a/test/core_lang_auto/get_attr.act +++ b/test/core_lang_auto/get_attr.act @@ -17,6 +17,16 @@ class Outer(object): self.flag = 99 self.inner = None +class Payload(object): + n: int + def __init__(self): + self.n = 11 + +class Carrier(object): + load: ?Payload + def __init__(self): + self.load = Payload() + actor main(env): o = Outer() ok = True @@ -54,6 +64,13 @@ actor main(env): if o.__get_attr__("nope") is not None: print("FAIL: nope should be None"); ok = False + # A constructed child observed ONLY through reflection: per-attribute + # __init__ slicing must honor the reflection escape like selection does, + # or the construction is sliced away and this reads None. + c = Carrier() + if c.__get_attr__("load") is None: + print("FAIL: load is None"); ok = False + if ok: print("get_attr ok") env.exit(0) From c7fc4d248bbcafd6a0357878aeff4ab572597f40 Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Tue, 18 Aug 2026 17:32:44 +0200 Subject: [PATCH 9/9] Document selective back passes Describe the exact interface rows and their keys, the module-owned hash component, consumer-specific projections, constructor fragments, opaque and native boundaries, output locks and the codegen key. Missing rows are errors and never widen the selection. --- .../src/compiler/imports_and_envs.md | 24 +- .../src/compiler/incremental_compilation.md | 265 +++++++++++------ .../src/compiler/interface_caches.md | 275 +++++++++++------- .../src/compiler/passes/codegen.md | 36 ++- .../src/compiler/passes/index.md | 34 ++- .../src/compilation/incremental.md | 89 ++++-- 6 files changed, 479 insertions(+), 244 deletions(-) diff --git a/docs/acton-dev-guide/src/compiler/imports_and_envs.md b/docs/acton-dev-guide/src/compiler/imports_and_envs.md index 36ca26d3d..0fe2b64eb 100644 --- a/docs/acton-dev-guide/src/compiler/imports_and_envs.md +++ b/docs/acton-dev-guide/src/compiler/imports_and_envs.md @@ -105,22 +105,15 @@ read; stale checks and DBP selection read exact `name-hash` rows on demand. Full reads are used when the compiler needs the full typed payload, not for normal imported-name lookup: -- implementation-hash refresh -- codegen refresh -- DBP back-pass fallback when selected statements cannot be reconstructed +- implementation-hash or codegen refresh for a compilation unit already + designated as a whole surface - tools that intentionally inspect a whole interface - completion fallback when the normal import environment cannot be restored Reading a full `.tydb` does not by itself reconstruct the import closure in the active environment. It only gives the caller the stored interface and typed -module payload. - -DBP interest is also scheduler metadata, not an import overlay. Each completed -front result contributes external dependency names into an `InterestMap`; for -cached modules those names are reconstructed from the `.tydb` dependency rows. -DBP later uses that map to prune a provider's typed module. That does not make -the selected provider names available to the active type-checker environment; -imports still become type-checker bindings only through `mkEnv`/`doImp`. +module payload. Selective back passes never use a full read as recovery: a +missing or inconsistent exact row is a cache/compiler error. ### Selective interface reads @@ -148,6 +141,15 @@ constructor, which preserves the ancestry-aware semantics of the old full scan. All transitive imports are consulted with keyed reads, so query cost is proportional to the number of imported modules, never to their size. +Deferred back passes use the same idea with a freshly resolved interface set. +After all required fronts commit, the scheduler closes executable and +whole-surface interest by reading only exact keyed rows demanded by the +worklist, then reads only the selected statement, container, and member content +rows. Each selection or materialization operation keeps an ordinary read +transaction open per participating interface. The reconstructed environment +uses the normal exact lazy name and query-index handles. Ordered source imports +and public interface hashes are part of the batch's codegen key. + Broad enumeration stays explicit. `from module import *` walks `modulePublicNames` and forces one lookup per importable public name. Completion, documentation, and debug paths may also choose broad reads, but diff --git a/docs/acton-dev-guide/src/compiler/incremental_compilation.md b/docs/acton-dev-guide/src/compiler/incremental_compilation.md index d97ec7889..caac9083b 100644 --- a/docs/acton-dev-guide/src/compiler/incremental_compilation.md +++ b/docs/acton-dev-guide/src/compiler/incremental_compilation.md @@ -6,13 +6,12 @@ the type-checker environment. Acton compiles a whole program by walking a dependency graph that spans the root project and all of its dependencies. The scheduler in `Acton.Compile` -builds this total graph, runs the front passes (parse, kinds, types) in -topological order, and normally queues back passes as soon as a module's front -passes finish. Deferred back pass (DBP) candidates are held until all modules -that can add interest for that candidate have completed their front passes. -Front work gates downstream modules, while ready back jobs overlap ongoing front -work. The scheduler runs tasks concurrently with async jobs across worker -threads. In watch/LSP mode, each change event bumps a generation id, cancels +builds this total graph and runs the front passes (parse, kinds, types) in +topological order. Whole-module back jobs can overlap ongoing front work. +Selective back jobs are held until all required front passes have succeeded, +because their reachability closure spans the complete program. The scheduler +runs tasks concurrently with async jobs across worker threads. In watch/LSP +mode, each change event bumps a generation id, cancels in-flight tasks, and drops stale diagnostics or back jobs that still carry the old generation, so we can react to new changes without waiting for obsolete work to finish. @@ -33,34 +32,47 @@ CPUs. The public hash (**modulePubHash**) is derived from the module's public-name `pubHash` values (which already include any external signature dependencies). -The implementation hash (**moduleImplHash**) is derived from per-name -`implHash` values; it is stored in the `.tydb` header. Normal generated -`.c`/`.h` files are tagged with this module implementation hash as an "Acton -impl hash". DBP generated files reuse the same tag but write a DBP codegen hash -that also includes the selected top-level names. If the tag is missing or -mismatched, we rerun back passes even if no other hashes changed. +The implementation hash (**moduleImplHash**) combines per-name `implHash` +values with a module-owned component. That component hashes the ordered source +imports, mandatory ownerless statements, and the ordered owner list for every +top-level statement. Reordering imports or independently hashed definitions +therefore changes the module hash when it changes module initialization order. +It is stored in the `.tydb` header. + +Generated `.c`/`.h` files carry an "Acton codegen hash". A whole-module back +pass combines the compiler identity and interface version with +`moduleImplHash`, `moduleSrcBytesHash`, and the line-emission mode, because +generated `#line` directives and source mappings depend on raw source and that +mode even when semantics do not change. Selective output instead fingerprints +the complete projection universe, including compiler identity and interface +version. A deferred module forced whole by a native provider +closure starts with the same implementation-plus-source hash and additionally +binds it to the public hashes in the resolved interface summaries for that +batch. Those summaries also retain the ordered source imports used to +rebuild each module environment. If the tag is missing or mismatched, we rerun +back passes even if no other hashes changed. Hashing within a module is done per top-level name. A hashable unit is a `Def`, `Actor`, `Class`, `Protocol`, `Extension`, or any top-level value introduced by a binding statement such as `a = 123` or `b, c = f()`. Entries are keyed by the local `Name`; external references are stored as `QName` (canonicalized to `GName` with `unalias`), and extensions use the derived name from -`extensionName`. For now class/actor implementation hashes are coarse and cover -the entire body; per-method hashing can refine this later. - -Each unit has three hashes. **srcHash** is the hash of the kinds-checked AST for -that name (pretty-printed), and is the earliest signal that a single declaration -changed. We use the kinds-checked form because it is the first pass that -normalizes type-level syntax (implicit type arguments, canonical kind structure) -without paying the cost of full type inference. Hashing the raw parsed AST would -make equivalent signatures hash differently and trigger needless rebuilds. -**pubHash** is the hash of the unit's public interface (doc-free `NameInfo`) -combined with the public hashes of external declarations referenced by its type -signature. **implHash** is the hash of the unit's implementation combined with -the implementation hashes of external declarations referenced from the body. -Because we hash pretty-printed source, docstrings currently influence -`implHash`; we can tighten the normalization later without changing the overall -model. +`extensionName`. Top-level expressions and control flow with no typed binding +belong to the module initialization component instead of an invented name. For +now class/actor implementation hashes are coarse and cover the entire body; +per-method hashing can refine this later. + +Each unit has three hashes. **srcHash** structurally hashes that name's fragments +from the parsed AST and is the earliest signal that a single declaration +changed. The feed ignores source locations and does not pass through the pretty +printer, so formatting and position changes do not alter a per-name source +hash. **pubHash** structurally hashes the unit's public interface (doc-free +`NameInfo`) together with the public hashes of external declarations referenced +by its type signature. **implHash** structurally hashes the final typed fragments +and combines them with the implementation hashes of declarations referenced +from the body. Declaration docstrings are still part of the parsed and typed +fragments, so they currently influence `srcHash` and `implHash`; that +normalization can be tightened without changing the dependency model. Name hashes depend on `NameInfo`. The type checker environment (`teAll`) is authoritative for user-facing declarations, but it does not include compiler- @@ -81,6 +93,12 @@ and is what triggers codegen and test invalidation. Local dependencies are stored separately as **pubLocalDeps** and **implLocalDeps** lists of `Name`s. Those local edges are folded into the computed hash during compilation, and they also give selective consumers such as DBP a cached local dependency graph. +The required `module-hash` row stores the ordered statement-owner schedule. Its +module-owned structural hash covers the ordered source imports and mandatory +ownerless statements. The latter additionally contribute local implementation +dependencies and external public/implementation snapshots to that row. Their +external dependencies also enter the normal dependency-module rows, without a +per-name user entry. Mutually recursive groups are hashed as a unit to avoid fixed-point iteration. We compute `selfPubHash`/`selfImplHash` for each unit, compute a `groupHash` @@ -93,7 +111,9 @@ Header reads return the per-name hashes in deterministic name order. See ``` version meta -- source metadata + module src/pub/impl hashes +module-hash -- source imports + owner schedule + ownerless init hash/deps imports +deps/* -- structurally keyed dependency-module rows name-hash/* -- per-name src/pub/impl hash + dep snapshots roots tests @@ -109,70 +129,127 @@ prints docs for the requested file. ## Deferred Back Passes -DBP is selected after type checking, when the full `NameHashInfo` list is -available. A module becomes a DBP candidate when its top-level name count is at -least the internal threshold (`1000` today), or when it is forced with -`--dbp MOD[:name,...]`. The option can be repeated, and explicit seed names are -unioned per module. DBP is disabled for `__builtin__`, `--only-build`, -alternate-output modes such as `--cgen`/`--hgen`, and whenever `--no-dbp` is -set. `--no-dbp` is a hard kill switch: it disables both the name-count -heuristic and explicit `--dbp` module requests. - -Modules at an explicit `Build.act` library boundary are also excluded from DBP. -A boundary module is a member of a declared library that is imported by any -module outside that same library. The library boundary needs the full generated -C/H surface, so even an explicit `--dbp` request compiles that module normally -and emits an info message. Internal library modules remain DBP-eligible. - -When a fresh front pass produces a DBP candidate, the scheduler stores a -`DeferredBackJob` instead of queueing a normal `BackJob`. Cached `TyTask` -modules can also register deferred jobs on later builds. This matters because -the provider source and implementation hash can stay unchanged while a consumer -starts selecting a different provider name. The scheduler also records -interested names in an `InterestMap`. Fresh front results contribute the -external dependency facts they just computed; cached modules reconstruct the -same interest set from the `.tydb` dependency rows. - -Deferred jobs do not wait for every front pass in the project. Their wait set is -the reverse dependency closure of the deferred module in the total build graph. -After each front stage completes, the scheduler flushes any deferred job whose -wait set is now contained in the completed-front set. If a module in that wait -set fails front passes, the normal failed-build path prevents the deferred back -job from running. - -When a deferred job is ready, DBP first reads the candidate's `.tydb` header. -It uses the header's `NameHashInfo` list and cached root actor names without -decoding the typed module. The initial selection seeds are: - -- explicit `--dbp MOD:name,...` names, when present; otherwise the collected - `InterestMap` names for the module -- cached root actor names from the `.tydb` header - -An empty interested-name set is valid; if the module has no root actors, DBP can -produce an effectively empty module body. DBP maps derived names back to their -owning top-level name, closes over `nhPubLocalDeps` and `nhImplLocalDeps`, and -uses exact `readExtensionsByClass` / `readExtensionsByProtocol` -lookups to keep top-level extension declarations required by selected classes -or protocols. Selection metadata that cannot map a seed, local dependency, or -extension back to a top-level name is a compiler error. DBP should not silently -fall back to full-module compilation except for modules that contain -`NotImplemented`/native hooks. - -Pruning happens on the typed module immediately before the normal back-pass -chain. Selected declarations, signatures, assignments, and compiler-introduced -`VarAssign` statements are retained by their bound top-level names; `Pass` is -dropped. Other source-level top-level statements are not a fallback case because -the parser rejects them before type checking. - -Before decoding the full typed module, DBP computes a codegen hash from the -module implementation hash and the sorted selected top-level names. If the -existing `.c` and `.h` files already carry that hash in their generated "Acton -impl hash" tag, the deferred job is skipped. Otherwise DBP reads the full typed -module with `readFile`, prunes it to the selected top-level declarations, runs -the normal back-pass chain, and writes `.c`/`.h` tagged with that DBP codegen -hash. A later consumer change that selects a different provider name therefore -makes the provider's DBP output stale even when the provider source did not -change. +Every eligible source module defers its back passes after the front passes have +committed its interface. Eligibility does not depend on module size or number +of names. Fresh and cached front results both register a `DeferredBackJob`, +which retains only paths, options, and the canonical module name so the large +typed front result can be released. `--no-dbp` disables this path. `__builtin__`, +modules containing `NotImplemented` native hooks, persistent `--db` builds, +`--only-build`, and alternate-output modes such as `--cgen` and `--hgen` use the +normal whole-module path. Database restoration is a dynamic root surface: an +actor or message class can be reached by its stored class id even when no +current source expression constructs it, so it remains whole until persistence +has an explicit schema/root manifest. A selection that reaches dynamic +`serialize` or `deserialize` also chooses a whole deferred batch because runtime +type names can reach classes not represented by static construction edges. + +After all required front passes succeed, the scheduler seeds one global +selection from the executable roots recorded in the root modules' interfaces: +`main`, `test_main`, or the explicitly named root. The worklist closes those +seeds across every selectively deferred module. Its persisted summaries carry +exact `Declare`, `Need`, `Construct`, direct member, dynamic dispatch, and +reflection edges using canonical module, top, and member names. Construction +also replays pending dispatch and reflection against newly reachable concrete +types. Every lookup is for one exact key; a missing or inconsistent reachable +row is a compiler error, and selection never substitutes a broader key. + +The front pass stores both syntax fragments and the semantic index needed by +that worklist: + +- top-level statement rows, compact container shapes, method ABI slots, and + member bodies keyed as `Method`, `Attr`, or `InitRest` +- reachability rows keyed by top, member, shape, effective slot, and reflectable + attribute, plus a mandatory module summary and a whole-module aggregate +- exact inferred headers and name hashes used to rebuild the selected type + environment and fingerprint opaque declarations + +The mandatory module summary is seeded for every selective module. The +whole-module summary aggregates all top, shape, member, initializer, generated +slot, and mandatory edges. A module whose own C/H surface must stay whole uses +that aggregate to contribute exact interest to selective providers without +loading all of those provider rows. It also records inherited class-table value +slots that whole CodeGen initializes unconditionally. + +Class-suite initialization and the declarative prefix of `__init__` are split +into per-attribute fragments. Selecting an attribute activates its class-suite +static initializer; its constructor fragment activates only when a compatible +receiver is initialized. Conditional class/actor-suite alternatives that +initialize several attributes are stored as an explicit atomic group, so +selecting one member adds the other exact named fragments in that group without +wildcard interest. The remaining constructor statements live in `InitRest`; +this preserves the +operational constructor body without retaining initializers for unselected +attributes. Nested control flow in the declarative prefix is projected with +the same per-attribute rule. + +Selection materializes a typed module projection directly from these `.tydb` +rows. It reads only the selected tops, container shapes, members, initializer +fragments, and compact inferred headers. It neither reads the source file nor +decodes a full typed module and then prunes it. The resulting projected module +and projected type environment enter the ordinary back-pass chain. Witness +forwarding is ordinary converted Acton syntax, so its provider dependencies +are selected through the same member and initializer rows as user code. + +Some compilation units deliberately form opaque boundaries. A directly +requested rootless module is a whole library surface. Within a declared +`Build.act` library, externally exposed or terminal modules likewise keep their +complete generated C/H surface, while internal provider modules remain +selective. These outputs are consumer-specific: a later consumer reruns the +provider selection instead of requiring every possible future public method in +the current artifact. Each whole surface contributes the exact interest of all +bodies it emits. Construct, direct-call, dispatch, and reflection edges can +traverse its persisted shape and slot rows into a selective inherited provider +without materializing the whole module. Across such an opaque inheritance +barrier, all inherited attributes are retained, including private padding, so +the whole subclass and projected base agree on object layout. + +`__builtin__` is opaque for code materialization, but source-backed builtin +functions retain their semantic reach summaries. Constructed witness +dictionaries retain every concrete slot. Runtime value conversion slots and +`__next__` are constructor obligations because native builtin code can invoke +them after the typed front tree has been summarized. These are bounded, +explicit runtime contracts rather than wildcard selection. + +A module containing `NotImplemented` is different because its hand-written +`.ext.c` can contain references absent from the typed Acton rows. Such a native +module and its transitive provider closure therefore run whole back passes. +This is a chosen compilation mode, not recovery from a failed selective +lookup. + +All project output roots participating in one selection share canonical, +sorted `.acton.output.lock` files. Dependency refresh and project discovery +happen before choosing that lock set; planning, interface reads, back passes, +and native consumption stay inside it. This prevents concurrent root projects +from replacing a shared provider projection underneath one another. + +One projection-universe hash covers the canonical selection facts, the +structural hashes of every materialized module and projected type environment, +and the interface fingerprints of selected opaque names. It is also bound to the +public hash of every interface captured for the lazy back-pass environment. +This last guard is deliberately conservative: codegen can still ask lazy +witness, descendant, attribute, and extension indexes questions that are not +represented by an exact selected content row. Until those query buckets have +their own persisted fingerprints, a public-interface change anywhere in the +captured closure invalidates the selective outputs. It does not widen selection +or load unrelated content, and implementation-only changes outside the +projection do not enter this guard. + +Each selected module's codegen hash combines that universe hash with its module +name. A changed consumer selection therefore invalidates its provider output. +Existing `.c` and `.h` files whose generated "Acton codegen hash" tags already +match are skipped. + +Selective reads start after all required front passes have committed their +interfaces. The compiler resolves the interface closure from compact summaries, +then keeps one ordinary LMDB read transaction per participating interface while +closing the reachability worklist. Materialization uses the same pattern for +the selected syntax and inferred headers. Ordered source imports and public +interface hashes from the resolved closure are included in the codegen key. + +The back-pass environment is rebuilt from fresh exact-read interface handles. +There is no additional cross-interface generation protocol: the scheduler +orders front and back work, and its own generation still prevents an obsolete +watch/LSP compile from publishing back-pass output. A source change always re-runs front passes for that module. Downstream modules compare recorded `pubDeps` against current provider hashes; any delta triggers @@ -273,7 +350,7 @@ $ rm out/types/b.c out/types/b.h $ acton build --verbose Building project in /path/proj Resolving dependencies (fetching if missing)... - Stale b: generated code out of date {impl c missing -> 7aa13f90, h missing -> 7aa13f90} + Stale b: generated code out of date {codegen c missing -> 7aa13f90, h missing -> 7aa13f90} Finished compilation of /path/proj/b 0.003 s ``` diff --git a/docs/acton-dev-guide/src/compiler/interface_caches.md b/docs/acton-dev-guide/src/compiler/interface_caches.md index 54e246391..5ceb3e7e8 100644 --- a/docs/acton-dev-guide/src/compiler/interface_caches.md +++ b/docs/acton-dev-guide/src/compiler/interface_caches.md @@ -9,10 +9,10 @@ in normal LMDB directory mode, with `data.mdb` as the durable payload and The compiler code should not construct these paths directly. Use the `InterfaceFiles` helpers, especially `interfacePath`, for cache paths. -## Compatibility Boundary +## Interface API -`InterfaceFiles` preserves the full-cache API and also exposes a selective -read API for imported-module lookup: +`InterfaceFiles` exposes full reconstruction, narrow imported-name lookups, and +the exact row reads used by selective back passes: - `writeFile` writes the cache for one module. - `readHeaderSummary` reads metadata, imports, the stored name count, roots, @@ -23,8 +23,21 @@ read API for imported-module lookup: statements. - `readFile` reconstructs the full cached payload: imports, `NameInfo`, typed module, metadata, module hashes, per-name hashes, roots, tests, and docstring. -- `readHeaderMaybe`, `readHeaderSummaryMaybe`, and `readFileMaybe` turn - missing, corrupt, unreadable, or version-mismatched caches into cache misses. +- `readModuleHashInfo` reads the statement-owner schedule, module-owned + import/initialization hash, and mandatory initialization dependencies without + loading statements or per-name hashes. +- `readModuleSnapshotMaybe` atomically reads the generation, module hashes, + identity, ordered source imports, closure imports, roots, native flag, and + documentation. +- `readReachModule` and `readReachWholeModule` read the mandatory and aggregate + summaries stored in the module reachability row. +- `readReachTop`, `readReachMember`, `readReachShape`, `readReachSlot`, and + `readReachReflection` read one exact reachability row. +- `readInterfaceSessionSelection` reconstructs one exact top/member/initializer projection + from the selected syntax rows. +- `readHeaderMaybe`, `readHeaderSummaryMaybe`, and `readFileMaybe` turn missing, + corrupt, or version-mismatched caches into cache misses. Other I/O and LMDB + failures propagate. - `openInterfaceDB` validates a `.tydb` for selective reads on the shared per-path environment; `openInterfaceDBMaybe` is its cache-miss form. - `readInterfaceDBModuleInfo` reads only import/doc metadata. @@ -35,10 +48,8 @@ read API for imported-module lookup: `readInterfaceDBExtByProto`, and `readInterfaceDBExtByType` read narrow query indexes. -That boundary lets the rest of the compiler keep treating cache access as a -plain lookup while the on-disk representation moves from one binary blob to a -keyed store. Full reads still rebuild the same payload as before, but normal -imported-module lookup no longer decodes every `NameInfo` entry. +Full reads rebuild the complete typed payload, while imported-name lookup and +selective back passes decode only the rows they request. ## LMDB Key Layout @@ -51,7 +62,8 @@ Metadata and module-level keys: | Key | Value type | | --- | --- | -| `version` | `[Int]` | +| `version` | `[Int]` (currently `[0,38]`) | +| `generation` | `ByteString` | | `meta` | `(Maybe SourceFileMeta, ByteString, ByteString, ByteString)` | | `imports` | `[(ModName, ByteString)]` | | `deps` | `[DepModuleInfo]` | @@ -64,11 +76,25 @@ Metadata and module-level keys: | `constructors` | `[Name]` | | `actors` | `[Name]` | | `stmt-count` | `Int` | +| `stmt-mandatory` | `[Int]` | | `stmt-has-not-impl` | `Bool` | - -The three `ByteString` hashes in `meta` are the module source-bytes hash, module -public hash, and module implementation hash. The `ByteString` stored with each -import is that imported module's public hash. +| `module-hash` | `ModuleHashInfo` | + +`generation` is a fresh 32-byte nonce for each semantic interface commit. It +changes even across an A -> B -> A rewrite, unlike a content hash. A module +snapshot captures it in the same transaction as the three hashes in `meta`, +the module header, ordered source imports, closure imports, roots, native flag, +and documentation. The `ByteString` stored with each closure import is that +imported module's public hash. + +`module-hash` is required for every current-version read. It stores one owner +list for each top-level statement in order, preserving initialization order +across independently hashed names. Its structural implementation hash covers +the ordered source imports and mandatory ownerless statements. It also stores +the ownerless statements' local implementation dependencies and their external +public and implementation dependency snapshots. These statements have no +top-level name, so this part is their module-owned counterpart to +`NameHashInfo`. The `deps` row stores every module whose names this module depends on, together with the recorded public and implementation hash for that dependency module. @@ -76,86 +102,110 @@ This row is the cheap stale-check gate: if both recorded module hashes still match the current dependency module hashes, the compiler does not need to read any per-name dependency rows for that module. -Extension indexes use the same suffix scheme as per-name entries, so readers -can look up one class or protocol without decoding the full index: +Extension indexes use the same structural name digest as per-name entries, so +readers can look up one class or protocol without decoding the full index: | Key | Value type | | --- | --- | -| `ext-by-class/p/` | `(Name, [Name])` | -| `ext-by-class/h/` | `(Name, [Name])` | -| `ext-by-protocol/p/` | `(Name, [Name])` | -| `ext-by-protocol/h/` | `(Name, [Name])` | +| `ext-by-class/h/` | `(Name, [Name])` | +| `ext-by-protocol/h/` | `(Name, [Name])` | The value repeats the keyed class or protocol name and stores the synthetic -top-level extension names produced by `extensionName`, which are also the names -used by per-name hashes and DBP pruning. This lets selective readers keep -extension declarations when a selected class, protocol, or local dependency -requires extension support. A returned extension must also be present in that -module's per-name hash records; otherwise the index is inconsistent with the -typed module. +top-level extension names produced by `extensionName`. These indexes support +exact imported-environment queries without decoding the complete `TEnv`. Per-name keys: | Key | Value type | | --- | --- | -| `name-order/` | `ByteString` suffix for a `name-info` key | -| `name-info/p/` | `(Name, NameInfo)` | -| `name-info/h/` | `(Name, NameInfo)` | -| `name-hash/p/` | `NameHashInfo` | -| `name-hash/h/` | `NameHashInfo` | +| `name-order/` | `ByteString` key of the corresponding ordered row | +| `name-info/order/` | `(Name, NameInfo)` | +| `name-info/h/` | `(Name, NameInfo)` | +| `name-hash/h/` | `NameHashInfo` | + +Every `TEnv` occurrence has its own `name-info/order/` row, and +`name-order/` points to that exact row. This preserves signatures and +definitions with the same `Name` in their original order. The direct +`name-info/h/` index stores the last occurrence, matching keyed +environment lookup semantics. Each `NameHashInfo` value contains the local name, `srcHash`, `pubHash`, `implHash`, local public/implementation dependency names -(`pubLocalDeps` / `implLocalDeps`), and the indexes of the typed top-level -statements owned by that name. External dependency snapshots are stored in -dependency rows instead of being repeated inside every `NameHashInfo`. +(`pubLocalDeps` / `implLocalDeps`), and the indexes of its top-level statement +rows. External dependency snapshots live in the dependency rows instead of +being repeated inside every `NameHashInfo`. Dependency rows: | Key | Value type | | --- | --- | -| `deps/` | `[DepNameInfo]` | -| `deps//p/` | `DepUsers` | -| `deps//h/` | `DepUsers` | - -`deps/` stores the dependency names used from that module and the -recorded public and implementation hash for each name. `DepUsers` stores the -local names that use one dependency name in their public and implementation -hashes. A stale check reads `deps/` only when the module-level hash gate -changed, then reads `deps//` only for names whose hashes actually -changed or went missing. - -Short safe source names are stored directly in key suffixes. Names longer than -400 bytes and names containing unsafe path-like bytes use SHA-256 based key -suffixes. Source names use their source text; derived and internal names use -the compiler-generated text from `rawstr`. `TEnv` entries are unique by `Name`; -`name-order/` stores the name suffix so full reads reconstruct the -original `TEnv` order without depending on LMDB cursor order. +| `deps/` | `[DepNameInfo]` | +| `deps/name/` | `DepUsers` | + +`deps/` uses the structural digest of the complete location-free +`ModName`; textual module renderings never form storage keys. It stores the +dependency names used from that module and the recorded public and +implementation hash for each name. A `deps/name` key similarly hashes the +complete module/name pair. Its `DepUsers` value stores top-level names using +that dependency; module-owned dependencies from `module-hash` deliberately +have no per-name user. A stale check reads the module row only after the +module-level hash gate changes, then reads exact dependency-name rows for names +that changed or disappeared. + +Name indexes use `h/` plus the SHA-256 digest of the complete location-free +`Name` value. Hashing the structure, rather than `rawstr`, keeps a source name +such as `ownerD_part` distinct from `Derived owner part`. Ordered rows +reconstruct the exact `TEnv` without depending on LMDB cursor order. Typed statements are stored by module order: | Key | Value type | | --- | --- | -| `stmt/` | `Stmt` | - -Statement order is preserved for full typed-module reconstruction. +| `stmt/` | `StoredStmt` | +| `shape/h/` | `ContainerShape` | +| `body/member//` | `MemberContentRow` | +| `reach/module/` | `(ModName, ReachSummary, ReachSummary)` | +| `reach/top/` | `ReachTopRow` | +| `reach/member//` | `ReachMemberRow` | +| `reach/shape/` | `ReachShapeRow` | +| `reach/slot//` | `ReachSlotRow` | +| `reach/reflection/` | `ReachReflectionRow` | + +`StoredStmt` preserves module order while separating container declarations +from their bodies. `stmt-mandatory` lists ownerless statements such as +top-level expressions and control flow; every projection includes those rows. +A shape stores the container header, structural suite, and method ABI slots. +Member rows independently store methods, attributes, per-attribute static and +instance initialization fragments, and the remaining constructor body +(`InitRest`). + +Reachability rows form the exact semantic index consumed by the global +worklist. The module row contains two summaries: dependencies of mandatory +ownerless statements, and a whole-module aggregate of every top, shape, member, +initializer, and generated-slot summary. Ordinary whole surfaces use the +aggregate to seed exact provider interest while those providers remain +selective. The other rows record top-level dependencies, member dependencies +and initializers, class/actor shape and lineage, effective dispatch slots, and +reflectable attributes. Top and member identities are source-location-free +semantic digests, and key/value identity is validated on read. Narrow query indexes are stored as separate keys, so solver and environment queries do not need to decode one combined module metadata value: | Key | Value type | | --- | --- | -| `con-attr/` | `[Name]` of public classes/actors declaring that attribute | -| `proto-attr/` | `[Name]` of public protocols declaring that attribute | -| `descendants/` | `[Name]` of public classes/protocols below that constructor | -| `ext-proto/` | `[Name]` of public extensions implementing that protocol | -| `ext-type/` | `[Name]` of public extensions for that type/class | +| `con-attr/h/` | `(Name, [Name])` for public classes/actors declaring that attribute | +| `proto-attr/h/` | `(Name, [Name])` for public protocols declaring that attribute | +| `descendants/` | `(QName, [Name])` of public classes/protocols below that constructor | +| `ext-proto/` | `(QName, [Name])` of public extensions implementing that protocol | +| `ext-type/` | `(QName, [Name])` of public extensions for that type/class | The `` suffix is a SHA-256 key for a source-location-free `QName`. -Attribute keys reuse the normal name-key suffix scheme. Readers resolve the -stored names through the matching `name-info/` entries, so the query -index itself stays small. The attribute indexes record attributes where they -are declared; readers complete inherited owners through the descendants index. +Attribute keys reuse the normal structural name digest. Readers resolve the +stored names through the matching `name-info/h/` entries, so the +query index itself stays small. The attribute indexes record attributes where +they are declared; readers complete inherited owners through the descendants +index. For example, `base/src/base64.act` contains top-level `encode` and `decode` definitions. Its `.tydb` uses these keys: @@ -163,21 +213,28 @@ definitions. Its `.tydb` uses these keys: ```text name-count -> 2 stmt-count -> 2 +stmt-mandatory -> [] +stmt-has-not-impl -> False +module-hash -> import hash + owner schedule [[encode], [decode]] +generation -> fresh 32-byte nonce -name-order/000000000000 -> p/encode -name-info/p/encode -> (Name "encode", NameInfo for encode) -name-order/000000000001 -> p/decode -name-info/p/decode -> (Name "decode", NameInfo for decode) +name-order/000000000000 -> name-info/order/000000000000 +name-info/order/000000000000 -> (Name "encode", NameInfo for encode) +name-info/h/ -> (Name "encode", NameInfo for encode) +name-order/000000000001 -> name-info/order/000000000001 +name-info/order/000000000001 -> (Name "decode", NameInfo for decode) +name-info/h/ -> (Name "decode", NameInfo for decode) -name-hash/p/decode -> NameHashInfo for decode -name-hash/p/encode -> NameHashInfo for encode +name-hash/h/ -> NameHashInfo for decode +name-hash/h/ -> NameHashInfo for encode deps -> dependency modules and module hashes -deps/__builtin__ -> dependency names and name hashes -deps/__builtin__/p/bytes -> local names using __builtin__.bytes +deps/ -> dependency names and name hashes +deps/name/ -> local names using __builtin__.bytes -stmt/000000000000 -> typed Stmt for encode -stmt/000000000001 -> typed Stmt for decode +stmt/000000000000 -> StoredStmt for encode +stmt/000000000001 -> StoredStmt for decode +reach/module/ -> empty mandatory + whole summaries ``` ## Read And Write Behavior @@ -187,23 +244,39 @@ keys plus the `deps` row and the stored name count. It does not decode `NameInfo` entries, per-name hash rows, or typed statements. Stale checks first compare the dependency module hashes in `deps`; if that gate changes, they use per-name dependency rows to decide which local names are affected. -DBP reads `roots` and exact `name-hash/` entries while expanding the -selected local dependency closure. When the selected codegen hash is stale, -`readSelectedModule` reconstructs a pruned typed module from only the selected -`stmt/` records; it falls back to `readFile` when statement ownership -is missing or the module contains NotImplemented hooks, whose -native-extension pairing needs the whole module. - -`readExtensionsByClass` and `readExtensionsByProtocol` read one class or -protocol key directly. DBP uses these exact lookups while expanding the selected -local dependency closure, mapping visited class/protocol names to the top-level -extension names that the typed module can actually retain. + +Selective back passes first resolve every interface in the closure after the +required front passes have committed. The global worklist keeps one read +transaction open per participating interface while it reads the mandatory +summary for each selective module, whole summaries for ordinary whole +surfaces, and exact `reach/*` rows for demanded tops, shapes, members, dispatch +slots, and reflection requests. Once the closure converges, +`readInterfaceSessionSelection` reads the mandatory statement rows plus only the selected +statement, shape, member, and initializer rows and reconstructs the projected +typed module. `SelectiveBack.materializeProjection` separately reads the +selected inferred headers and merges the projected type environment. Each +materialization operation likewise keeps an ordinary read transaction open for +each participating interface. + +A missing or inconsistent reachable row or an unusable selected content row is +a compiler error. An exact selection run neither widens the key nor falls back +to full module or source loading. Rootless surfaces and +exposed `Build.act` library modules are chosen as ordinary whole surfaces and +seed selective internal providers through their whole summaries and exact +opaque shape/slot routing. The artifact is consumer-specific; a later consumer +recomputes the projection instead of broadening the present one to every public +surface. A native +`NotImplemented` module instead forces its transitive provider closure whole, +because hand-written `.ext.c` references are not represented in typed rows. +Persistent `--db` builds also stay whole because restored class ids are dynamic +roots. Dynamic `serialize` or `deserialize` interest likewise chooses a whole +deferred batch because runtime type names are not bounded by static edges. These +are chosen modes, not error recovery. `readFile` opens a read-only transaction and reconstructs the full payload by following the explicit order keys for ordered sections. It does not depend on LMDB cursor order for `TEnv` or typed statement reconstruction. DBP calls this -only when selected statement reconstruction cannot serve a stale -selection-sensitive codegen output. +only for compilation units already designated as whole surfaces. All readers share one cached read-only LMDB environment per `.tydb` path, opened with the normal reader lock table so concurrent writers in other @@ -211,30 +284,32 @@ processes cannot recycle pages under an active read transaction. Writers keep their exclusive per-path lock and retire the cached environment, waiting for active readers to drain, before opening their own, so the process never holds two environments for one path. `openInterfaceDB` validates the version once -and hands `Acton.Env` a handle it installs in a `ModuleInfo`; later -exact-name lookups call `readInterfaceDBNameInfoMaybe`, which runs a short -read transaction on the shared environment and decodes only the demanded -`name-info/` value. Those reads sit behind Env's pure-looking lookup -functions and are memoized per module. +and hands `Acton.Env` a handle it installs in a `ModuleInfo`; later exact-name +lookups call `readInterfaceDBNameInfoMaybe`, which runs a short read transaction +on the shared environment and decodes only the demanded +`name-info/h/` value. Selective back passes build a fresh environment +from the explicit interface set resolved for the batch; lazy name and +query-index lookups use the same exact readers. The same handle exposes the narrow query readers for non-name solver questions: actor lookup reads `actors`; attribute lookup reads -`con-attr/` or `proto-attr/`; descendant lookup reads one +`con-attr/h/` or `proto-attr/h/`; descendant lookup reads one `descendants/` record; and witness lookup reads `ext-proto/` or `ext-type/`. Plain imports do not read these records. -`writeFile` writes the full environment in one write transaction. The compiler -has one writer for a module cache, while multiple readers may run in parallel. +`writeFile` writes the full environment in one LMDB write transaction. The +compiler has one writer for a module cache, while multiple readers may run in +parallel. The raw Haskell LMDB binding can race when several threads open the same environment at once, so `InterfaceFiles` serializes only environment opening. The read transactions themselves are still independent. -Within a single compiler process, completed front results are the authoritative -interface source for downstream front passes. The import loader should prefer -the in-memory `Env.modules` entry when a module has already been loaded, and use -`.tydb` only for modules absent from that environment. This lets `.tydb` writes -run asynchronously without making dependent front stages wait for the LMDB -directory to become readable. +The `.tydb` commit is synchronous with front completion. A module cannot report +its front passes complete until all interface rows are committed on disk, so +dependent readers never wait for or race an in-flight interface write. A write +failure fails that module's front pass. Documentation output and an explicitly +requested interface copy may still run in the background because this build +does not read them back. `copyInterface` uses LMDB's environment copy API. It copies durable data without copying a stale `lock.mdb`, so copied `--tydb` artifacts reopen with fresh LMDB diff --git a/docs/acton-dev-guide/src/compiler/passes/codegen.md b/docs/acton-dev-guide/src/compiler/passes/codegen.md index 1e2c78e5e..1fcbac6a3 100644 --- a/docs/acton-dev-guide/src/compiler/passes/codegen.md +++ b/docs/acton-dev-guide/src/compiler/passes/codegen.md @@ -2,16 +2,38 @@ Implementation lives in `compiler/lib/src/Acton/CodeGen.hs`. -`Acton.CodeGen.generate` receives the hash string that should be stamped into +`Acton.CodeGen.generate` receives the hash string stamped into the generated output. It writes that hash as the first line of both `.c` and `.h` files: ```c -/* Acton impl hash: ... */ +/* Acton codegen hash: ... */ ``` -For normal modules, `Acton.Compile` passes the module implementation hash. For -DBP modules, it passes the DBP codegen hash derived from the module -implementation hash plus the selected top-level names. The label is therefore -historical: in DBP output it is a selection-sensitive generated-code hash, not -just the raw module implementation hash. +A whole-module back pass combines the compiler-binary identity, interface +version, line-emission mode, module implementation hash, and raw source hash. +The raw bytes and line mode are part of the generated-code key because codegen +emits `#line` directives and other source mappings that can change without a +semantic implementation change. + +For selective output, one whole-program projection hash fingerprints the exact +global selection, every materialized module and projected type environment, +the exact selected names at opaque boundaries, the compiler identity, and the +interface version. Each module's codegen hash +combines that projection hash with its module name. A deferred module forced +whole by a native provider closure starts with the ordinary whole-module hash +and additionally binds it to the public hashes in the resolved interface +summaries for that batch. Those summaries also retain the ordered source +imports used to rebuild each module environment. A change in +consumer interest therefore invalidates affected selective provider output even +when the provider's source is unchanged, while a lazy interface change cannot +leave forced-whole output stale. + +The summary binding covers every interface in the resolved lazy back-pass +environment. This deliberately conservative guard covers codegen's descendant, +attribute, and extension index callbacks, whose exact query buckets do not yet +have persisted fingerprints. A public-interface +change anywhere in that closure can therefore invalidate selective output even +when no content row from that interface was selected. This does not materialize +unrelated rows; implementation-only changes outside the projection remain +outside the semantic codegen hash. diff --git a/docs/acton-dev-guide/src/compiler/passes/index.md b/docs/acton-dev-guide/src/compiler/passes/index.md index df9fca43e..db44804e6 100644 --- a/docs/acton-dev-guide/src/compiler/passes/index.md +++ b/docs/acton-dev-guide/src/compiler/passes/index.md @@ -32,19 +32,20 @@ For how imports are loaded before these passes run, see The pipeline is split into a front end and a back end. The scheduler runs front passes across the dependency graph, then queues back-pass work once type -checking succeeds for a module. Normal modules queue their back job immediately. -DBP candidates hold a deferred back job until all reverse-dependent front passes -that can add interest have completed. +checking succeeds for a module. Whole-surface modules can queue their back job +immediately. Eligible selective modules retain only a reloadable deferred job +until all front passes needed by the global reachability closure have +completed. Front passes (1–3) are: - Parse - Kinds check - Type check -These passes produce all user-facing diagnostics, write the module interface -cache (`.tydb`), and compute public hashes used for incremental rebuilds. They -also define the cross-module dependency edges: a module can only start once its -imports have completed the front passes. +These passes produce all user-facing diagnostics, compute public hashes used +for incremental rebuilds, and commit the module interface cache (`.tydb`) +before reporting front completion. They also define the cross-module dependency +edges: a module can only start once its imports have completed the front passes. Back passes (4–9) are: - Normalize @@ -60,10 +61,21 @@ front completion and even in the background. The CLI waits for all back jobs to finish before invoking Zig; the LSP enqueues back jobs in the background and does not wait for them or run Zig. -DBP still runs the same back-pass sequence once it is ready. The difference is -that it may prune the typed module to the selected top-level declarations before -normalization, and it can skip the back job entirely when the selected DBP -codegen hash already matches the generated `.c`/`.h` files. +DBP still runs the same back-pass sequence once it is ready. After all required +front passes finish, one exact whole-program reachability closure starts at the +executable roots and the persisted whole summaries of ordinary whole surfaces, +then crosses module boundaries. Each selectively compiled module is materialized +from exact `.tydb` rows as a typed projection containing only the selected +top-level declarations, container methods and attributes, and their activated +initialization fragments. That projection enters normalization; no full typed +module is loaded and pruned afterward. Internal providers of a declared library +remain selective. Native `NotImplemented` modules and their provider closure +run whole back passes because hand-written C can contain hidden references. +Persistent `--db` builds also run whole because restored class ids are dynamic +roots. Dynamic `serialize` or `deserialize` interest makes the deferred batch +whole because runtime type names can escape the static reachability graph. A +matching projection-aware codegen hash lets the compiler skip the back job +entirely. The shared orchestration lives in `compiler/lib/src/Acton/Compile.hs` and is used by both `acton` and the LSP server. diff --git a/docs/acton-guide/src/compilation/incremental.md b/docs/acton-guide/src/compilation/incremental.md index b57d283f2..85e2cf27a 100644 --- a/docs/acton-guide/src/compilation/incremental.md +++ b/docs/acton-guide/src/compilation/incremental.md @@ -4,18 +4,27 @@ Acton tracks changes at a finer level than whole modules so builds stay fast as ## What gets hashed and tracked -- **moduleSrcBytesHash**: hash of the raw bytes for a whole `.act` file. It is very cheap to read and hash a `.act` file from disk (GB/s). This is stored in the `.ty` file and is the authority for deciding whether a cached typed module still matches the source. Parsing is not incremental, it only supports re-parsing a complete module, which is also why a single hash for the entire `.act` module file makes sense. -- **per-name srcHash**: hash of a name's source code. Since this is only the hash of the source code, it can be computed after the parser and before type checking in order to determine what functions we need to rerun through later passes, including type checking which is typically a relatively expensive pass. Note how the next pubHash and implHash are after type checking, so they cannot be used in order to determine if type-checking should be rerun for a function. +- **moduleSrcBytesHash**: hash of the raw bytes for a whole `.act` file. It is very cheap to read and hash a `.act` file from disk (GB/s). This is stored in the `.tydb` cache and is the authority for deciding whether a cached typed module still matches the source. Parsing is not incremental, it only supports re-parsing a complete module, which is also why a single hash for the entire `.act` module file makes sense. +- **per-name srcHash**: hash of a name's source-level definition, assembled + after the module has completed its front passes. It identifies which names + changed for diagnostics and later hash assembly; front passes are not + incremental within one changed module, so parsing and type checking still + rerun for the complete module. - **per-name pubHash**: hash of a name's public interface (its type signature). Downstream modules only need to re-typecheck if a pubHash they depend on changes. The pubHash also contains the hashes of dependencies, and if those change, our pubHash will change, thus causing re-typecheck. - **per-name implHash**: hash of a name's implementation plus the impl hashes it depends on. If an implHash changes, we re-run back passes and tests. +- **module-owned implHash**: hash of the ordered source imports, mandatory top-level statements with no typed binding, and the ordered ownership schedule of all top-level statements, combined with the mandatory statements' local and external implementation dependencies. It participates in the whole-module implementation hash, so changing import or initialization order is observable even when the individual names are unchanged. - **per-name pubDeps**: the public (type signature) hashes of other names that we depend on. If the hashes of any deps change, we must re-typecheck. - **per-name implsDeps**: the hashes of the implementation of other names that we depend on. If the hashes of any deps change, we must rerun back passes. -Most names have both a pubHash and implHash. Some derived internal names only have implHash. +Most names have both a pubHash and implHash. Some derived internal names only +have implHash. Mandatory ownerless statements are tracked by the module-owned +component instead of being assigned a synthetic name; its dependency snapshots +include both provider public and implementation hashes. -## How `.ty` cache validity is decided +## How `.tydb` cache validity is decided -Each module gets a cached typed interface file in `out/types/.ty`. +Each module gets a cached typed interface database in +`out/types/.tydb/`. That cache stores: - the module source content hash (`moduleSrcBytesHash`) @@ -30,16 +39,16 @@ The important rule is: In practice, Acton decides reuse like this: -1. If the `.ty` file is missing, unreadable, or from an incompatible cache - schema version, Acton reparses the `.act` file and rebuilds the `.ty`. +1. If the `.tydb` cache is missing, unreadable, or from an incompatible cache + schema version, Acton reparses the `.act` file and rebuilds the `.tydb`. 2. If the cached source metadata still matches the current source file and the - source mtime is strictly older than the `.ty` mtime, Acton reuses the `.ty` - header immediately without reading and hashing the source. -3. If the metadata differs, or the source and `.ty` mtimes are equal, Acton - reads the `.act` file and compares its content hash to the stored - `moduleSrcBytesHash`. + source mtime is strictly older than the `.tydb` data-file mtime, Acton reuses + the cache header immediately without reading and hashing the source. +3. If the metadata differs, or the source and `.tydb` data-file mtimes are + equal, Acton reads the `.act` file and compares its content hash to the + stored `moduleSrcBytesHash`. 4. If the hash matches, the source content is unchanged, so Acton reuses the - cached `.ty` and refreshes the stored source metadata. + cached `.tydb` and refreshes the stored source metadata. 5. If the hash differs, the source really changed, so Acton reparses and recompiles that module. @@ -48,12 +57,12 @@ or cross-machine sync, does not by itself force a front-end rebuild. It also means misleading timestamps cannot cause stale typed-module reuse, because Acton falls back to the source content hash before trusting the cache. -The strict `source mtime < .ty mtime` check matters on filesystems with coarse -mtime resolution. If a source edit and `.ty` write land in the same timestamp -tick, equal mtimes are ambiguous: the source may already have changed even -though the cached source metadata still looks identical. Acton therefore treats -equal source and `.ty` mtimes as a signal to hash the current source instead of -taking the metadata-only fast path. +The strict `source mtime < .tydb data-file mtime` check matters on filesystems +with coarse mtime resolution. If a source edit and `.tydb` write land in the +same timestamp tick, equal mtimes are ambiguous: the source may already have +changed even though the cached source metadata still looks identical. Acton +therefore hashes the current source instead of taking the metadata-only fast +path. ## What changes cause what work @@ -96,11 +105,49 @@ Stale c: pub changes in a.a (used by _test_foo) **Add or remove an unused import** -If no name actually uses the import, per-name deps do not change, so nothing propagates. Changes are only computed and propagated for names that are actually in use, which also means that it is possible to create quite large and monolithic modules without paying a higher cost for longer compilation times of downstream dependents. +The edited module reruns its front passes, and its ordered import list changes +the module-owned implementation hash. If no name actually uses the import, +per-name dependencies do not change, so the change does not propagate to +downstream modules. Changes are only propagated for names that are actually in +use, which also means that it is possible to create quite large and monolithic +modules without paying a higher cost for longer compilation times of downstream +dependents. ## Code generation staleness -Generated C/H files embed the module impl hash. If the embedded hash differs from the current module impl hash, the compiler treats the generated code as out of date and regenerates it. +Generated C/H files embed an Acton codegen hash. An ordinary whole-module output +combines the compiler identity and interface version with the module +implementation hash, raw source hash, and line-emission mode. Raw bytes and the +line mode matter because `#line` directives and other source mappings can +change without a semantic change. +Selective output fingerprints the exact whole-program projection, so changed +consumer interest also invalidates affected provider output. A module forced +whole as part of a native provider closure starts with the same whole-module +hash and additionally binds it to the public hashes in that batch's resolved +interface summaries. Those summaries also retain the ordered source imports +used to rebuild module environments. If the embedded codegen hash differs from +the current one, the compiler regenerates the C/H files. + +Selective back passes start at executable roots and materialize only the exact +top-level names, methods, attributes, and initialization fragments reached from +them. A directly requested library surface stays whole, but its internal +providers can still be selective: the whole surface records the exact provider +interest of everything it emits and routes inherited construction and calls +through exact provider slots. The projection is specific to the consumers in +the current build; compiling a different consumer recomputes it. Declared +library entry points work the same way. Modules implemented by native +`NotImplemented` bodies are the exception; their provider closure stays whole +because hand-written C can contain references that are not visible in Acton +source. Persistent `--db` builds also stay whole because stored class ids can +restore actors and messages that have no current static construction edge. +Reaching dynamic `serialize` or `deserialize` also makes the deferred batch +whole because runtime type names can reach classes absent from static edges. + +The codegen hash conservatively includes the public hashes of the complete +resolved interface closure because witness and type-index queries can remain +lazy during codegen. Thus an unselected public-interface change may regenerate +selective output, although unrelated content rows are still never loaded and +implementation-only changes outside the projection do not affect this guard. ## Tests and hashes