diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index de6875bdf8..f6b3dd58ac 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -324,9 +324,21 @@ entails SolverOptions{..} constraint context hints = let subst = fmap head substs currentSubst <- lift . lift $ gets checkSubstitution subst' <- lift . lift $ withFreshTypes tcd (fmap (substituteType currentSubst) subst) - lift . lift $ zipWithM_ (\t1 t2 -> do - let inferredType = replaceAllTypeVars (M.toList subst') t1 - unifyTypes inferredType t2) (tcdInstanceTypes tcd) tys'' + -- Row.Cons specialization: bypass sort+align, use O(n) linear scan. + -- For all other classes, use the generic fundep enforcement. + lift . lift $ case (className', tcdInstanceTypes tcd, tys'') of + (cn', TypeLevelString _ sym : ty : r : _, _ : _ : _ : goalRow : _) + | cn' == C.RowCons + -> case removeRowLabel (Label sym) goalRow of + Just (goalTy, restRow) -> do + withErrorMessageHint (ErrorInRowLabel (Label sym)) $ + unifyTypes ty goalTy + unifyTypes r restRow + Nothing -> + unifyTypes (srcRCons (Label sym) ty r) goalRow + _ -> zipWithM_ (\t1 t2 -> do + let inferredType = replaceAllTypeVars (M.toList subst') t1 + unifyTypes inferredType t2) (tcdInstanceTypes tcd) tys'' currentSubst' <- lift . lift $ gets checkSubstitution let subst'' = fmap (substituteType currentSubst') subst' -- Solve any necessary subgoals @@ -707,6 +719,15 @@ entails SolverOptions{..} constraint context hints = Just [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowCons [] kinds [TypeLevelString ann sym, ty, r, srcRCons (Label sym) ty r] Nothing Nothing ] solveRowCons _ _ = Nothing + -- | Remove a label from a row type, returning the matched field type + -- and the row with that entry removed. O(n) linear scan. + -- Used by the Row.Cons specialization in fundep enforcement. + removeRowLabel target = go id where + go rebuild (RCons ann l t rest) + | l == target = Just (t, rebuild rest) + | otherwise = go (rebuild . RCons ann l t) rest + go _ _ = Nothing + solveRowToList :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveRowToList [kind] [r, _] = do entries <- rowToRowList kind r diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 72b8086599..52af84daab 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -170,11 +170,53 @@ unifyTypes t1 t2 = do -- -- Common labels are identified and unified. Remaining labels and types are unified with a -- trailing row unification variable, if appropriate. +-- +-- Fast path: when both rows have RCons entries with matching labels in order, +-- unify field types directly without sorting. Falls back to sort + alignment +-- on the first label mismatch or when one side is exhausted. unifyRows :: SourceType -> SourceType -> TypeCheckM () -unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where - unifyTypesWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ unifyTypes t1 t2 +unifyRows r1 r2 = fastPath r1 r2 where + -- Walk both RCons chains in parallel. When labels match, unify types + -- in O(1) per entry. On mismatch, fall back to sort+align on the + -- remaining (shorter) rows. + fastPath (RCons _ l1 t1 rest1) (RCons _ l2 t2 rest2) + | l1 == l2 = do + withErrorMessageHint (ErrorInRowLabel l1) $ unifyTypes t1 t2 + fastPath rest1 rest2 + -- Single-entry scan: when one side has exactly one RCons entry (tail + -- is not RCons), scan the other side linearly for the matching label. + -- O(n) instead of O(n log n). Common path for Row.Cons constraints. + fastPath r1'@(RCons _ l1 t1 tail1) r2'@RCons{} + | notRCons tail1 + = case removeLabel l1 r2' of + Just (t2, rest2) -> do + withErrorMessageHint (ErrorInRowLabel l1) $ unifyTypes t1 t2 + unifyTypes tail1 rest2 + Nothing -> slowPath r1' r2' + fastPath r1'@RCons{} r2'@(RCons _ l2 t2 tail2) + | notRCons tail2 + = case removeLabel l2 r1' of + Just (t1, rest1) -> do + withErrorMessageHint (ErrorInRowLabel l2) $ unifyTypes t1 t2 + unifyTypes tail2 rest1 + Nothing -> slowPath r1' r2' + fastPath rest1 rest2 = slowPath rest1 rest2 + + notRCons RCons{} = False + notRCons _ = True + + -- Remove a label from a row, returning the matched field type and + -- the row with that entry removed. O(n) linear scan. + removeLabel target = go id where + go rebuild (RCons ann l t rest) + | l == target = Just (t, rebuild rest) + | otherwise = go (rebuild . RCons ann l t) rest + go _ _ = Nothing - (matches, rest) = alignRowsWith unifyTypesWithLabel r1 r2 + -- Sort both sides and do merge-join alignment (original algorithm). + slowPath r1' r2' = sequence_ matches *> uncurry unifyTails rest where + unifyTypesWithLabel l t1' t2' = withErrorMessageHint (ErrorInRowLabel l) $ unifyTypes t1' t2' + (matches, rest) = alignRowsWith unifyTypesWithLabel r1' r2' unifyTails :: ([RowListItem SourceAnn], SourceType) -> ([RowListItem SourceAnn], SourceType) -> TypeCheckM () unifyTails ([], TUnknown _ u) (sd, r) = solveType u (rowFromList (sd, r))