diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index 528f6d1ef..a00a75eec 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/src/compiler/GF/Compile/GrammarToLPGF.hs @@ -15,10 +15,8 @@ import GF.Infra.UseIO (IOE) import GF.Text.Pretty (pp, render) import Control.Applicative ((<|>)) -import Control.Monad (when, unless, forM, forM_) -import qualified Control.Monad.State as CMS -import Data.Either (lefts, rights) -import qualified Data.IntMap as IntMap +import Control.Monad (when, forM, forM_) +import qualified Control.Monad.State.Strict as CMS import Data.List (elemIndex) import qualified Data.List as L import qualified Data.Map.Strict as Map @@ -39,7 +37,7 @@ mkCanon2lpgf opts gr am = do ppCanonical debugDir canon dumpCanonical debugDir canon (an,abs) <- mkAbstract ab - cncs <- mapM (mkConcrete debug) cncs + cncs <- mapM (mkConcrete debug ab) cncs let lpgf = LPGF { L.absname = an, L.abstract = abs, @@ -50,247 +48,267 @@ mkCanon2lpgf opts gr am = do where canon@(C.Grammar ab cncs) = grammar2canonical opts am gr - mkAbstract :: (ErrorMonad err) => C.Abstract -> err (CId, L.Abstract) - mkAbstract (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstract {}) +mkAbstract :: (ErrorMonad err) => C.Abstract -> err (CId, L.Abstract) +mkAbstract (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstract {}) - mkConcrete :: (ErrorMonad err) => Bool -> C.Concrete -> err (CId, L.Concrete) - mkConcrete debug (C.Concrete modId absModId flags params' lincats lindefs) = do - let - (C.Abstract _ _ _ funs) = ab - params = inlineParamAliases params' +mkConcrete :: (ErrorMonad err) => Bool -> C.Abstract -> C.Concrete -> err (CId, L.Concrete) +mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params0 lincats lindefs0) = do + let + -- Some transformations on canonical grammar - -- Builds maps for lookups + params :: [C.ParamDef] + params = inlineParamAliases params0 - paramValueMap :: Map.Map C.ParamId C.ParamDef -- constructor -> definition - paramValueMap = Map.fromList [ (v,d) | d@(C.ParamDef _ vs) <- params, (C.Param v _) <- vs ] + lindefs :: [C.LinDef] + lindefs = + [ C.LinDef funId varIds linValue' + | (C.LinDef funId varIds linValue) <- lindefs0 + , let Right linType = lookupLinType funId + , let linValue' = cleanupRecordFields linValue linType + ] - lincatMap :: Map.Map C.CatId C.LincatDef - lincatMap = Map.fromList [ (cid,d) | d@(C.LincatDef cid _) <- lincats ] - - funMap :: Map.Map C.FunId C.FunDef - funMap = Map.fromList [ (fid,d) | d@(C.FunDef fid _) <- funs ] - - -- | Lookup paramdef, providing dummy fallback when not found - -- Workaround for https://github.com/GrammaticalFramework/gf-core/issues/100 - lookupParamDef :: C.ParamId -> Either String C.ParamDef - lookupParamDef pid = case Map.lookup pid paramValueMap of - Just d -> Right d - Nothing -> - -- Left $ printf "Cannot find param definition: %s" (show pid) - Right $ C.ParamDef (C.ParamId (C.Unqual "DUMMY")) [C.Param pid []] - - -- | Lookup lintype for a function - lookupLinType :: C.FunId -> Either String C.LinType - lookupLinType funId = do - fun <- m2e (printf "Cannot find type for: %s" (show funId)) (Map.lookup funId funMap) - let (C.FunDef _ (C.Type _ (C.TypeApp catId _))) = fun - lincat <- m2e (printf "Cannot find lincat for: %s" (show catId)) (Map.lookup catId lincatMap) - let (C.LincatDef _ lt) = lincat - return lt - - -- | Lookup lintype for a function's argument - lookupLinTypeArg :: C.FunId -> Int -> Either String C.LinType - lookupLinTypeArg funId argIx = do - fun <- m2e (printf "Cannot find type for: %s" (show funId)) (Map.lookup funId funMap) - let (C.FunDef _ (C.Type args _)) = fun - let (C.TypeBinding _ (C.Type _ (C.TypeApp catId _))) = args !! argIx - lincat <- m2e (printf "Cannot find lincat for: %s" (show catId)) (Map.lookup catId lincatMap) - let (C.LincatDef _ lt) = lincat - return lt - - -- Filter out record fields from definitions which don't appear in lincat. - -- Workaround for https://github.com/GrammaticalFramework/gf-core/issues/101 - cleanupRecordFields :: C.LinValue -> C.LinType -> C.LinValue - cleanupRecordFields (C.RecordValue rrvs) (C.RecordType rrs) = - let defnFields = Map.fromList [ (lid, lt) | (C.RecordRow lid lt) <- rrs ] - in C.RecordValue - [ C.RecordRow lid lv' - | C.RecordRow lid lv <- rrvs - , Map.member lid defnFields - , let Just lt = Map.lookup lid defnFields - , let lv' = cleanupRecordFields lv lt - ] - cleanupRecordFields lv _ = lv - - lindefs' = - [ C.LinDef funId varIds linValue' - | (C.LinDef funId varIds linValue) <- lindefs - , let Right linType = lookupLinType funId - , let linValue' = cleanupRecordFields linValue linType + -- Filter out record fields from definitions which don't appear in lincat. + -- Workaround for https://github.com/GrammaticalFramework/gf-core/issues/101 + cleanupRecordFields :: C.LinValue -> C.LinType -> C.LinValue + cleanupRecordFields (C.RecordValue rrvs) (C.RecordType rrs) = + let defnFields = Map.fromList [ (lid, lt) | (C.RecordRow lid lt) <- rrs ] + in C.RecordValue + [ C.RecordRow lid lv' + | C.RecordRow lid lv <- rrvs + , Map.member lid defnFields + , let Just lt = Map.lookup lid defnFields + , let lv' = cleanupRecordFields lv lt ] - es = map mkLin lindefs' - lins = Map.fromList $ rights es + cleanupRecordFields lv _ = lv - -- | Main code generation function - mkLin :: C.LinDef -> Either String (CId, L.LinFun) - mkLin (C.LinDef funId varIds linValue) = do - -- when debug $ trace funId - (lf, _) <- val2lin linValue - return (fi2i funId, lf) - where - val2lin :: C.LinValue -> Either String (L.LinFun, Maybe C.LinType) - val2lin lv = case lv of + -- Builds maps for lookups - C.ConcatValue v1 v2 -> do - (v1',t1) <- val2lin v1 - (v2',t2) <- val2lin v2 - return (L.Concat v1' v2', t1 <|> t2) -- t1 else t2 + paramValueMap :: Map.Map C.ParamId C.ParamDef -- constructor -> definition + paramValueMap = Map.fromList [ (v,d) | d@(C.ParamDef _ vs) <- params, (C.Param v _) <- vs ] - C.LiteralValue ll -> case ll of - C.FloatConstant f -> return (L.Token $ T.pack $ show f, Just C.FloatType) - C.IntConstant i -> return (L.Token $ T.pack $ show i, Just C.IntType) - C.StrConstant s -> return (L.Token $ T.pack s, Just C.StrType) + lincatMap :: Map.Map C.CatId C.LincatDef + lincatMap = Map.fromList [ (cid,d) | d@(C.LincatDef cid _) <- lincats ] - C.ErrorValue err -> return (L.Error err, Nothing) + funMap :: Map.Map C.FunId C.FunDef + funMap = Map.fromList [ (fid,d) | d@(C.FunDef fid _) <- funs ] - C.ParamConstant (C.Param pid lvs) -> do - let - collectProjections :: C.LinValue -> Either String [L.LinFun] - collectProjections (C.ParamConstant (C.Param pid lvs)) = do - def <- lookupParamDef pid - let (C.ParamDef tpid defpids) = def - pidIx <- eitherElemIndex pid [ p | C.Param p _ <- defpids ] - rest <- mapM collectProjections lvs - return $ L.Ix (pidIx+1) : concat rest - collectProjections lv = do - (lf,_) <- val2lin lv - return [lf] - lfs <- collectProjections lv - let term = L.Tuple lfs - def <- lookupParamDef pid - let (C.ParamDef tpid _) = def - return (term, Just $ C.ParamType (C.ParamTypeId tpid)) + -- | Lookup paramdef, providing dummy fallback when not found + -- Workaround for https://github.com/GrammaticalFramework/gf-core/issues/100 + lookupParamDef :: C.ParamId -> Either String C.ParamDef + lookupParamDef pid = case Map.lookup pid paramValueMap of + Just d -> Right d + Nothing -> + -- Left $ printf "Cannot find param definition: %s" (show pid) + Right $ C.ParamDef (C.ParamId (C.Unqual "DUMMY")) [C.Param pid []] - C.PredefValue (C.PredefId pid) -> case pid of - "BIND" -> return (L.Bind, Nothing) - "SOFT_BIND" -> return (L.Bind, Nothing) - "SOFT_SPACE" -> return (L.Space, Nothing) - "CAPIT" -> return (L.Capit, Nothing) - "ALL_CAPIT" -> return (L.AllCapit, Nothing) - _ -> Left $ printf "Unknown predef function: %s" pid + -- | Lookup lintype for a function + lookupLinType :: C.FunId -> Either String C.LinType + lookupLinType funId = do + fun <- m2e (printf "Cannot find type for: %s" (show funId)) (Map.lookup funId funMap) + let (C.FunDef _ (C.Type _ (C.TypeApp catId _))) = fun + lincat <- m2e (printf "Cannot find lincat for: %s" (show catId)) (Map.lookup catId lincatMap) + let (C.LincatDef _ lt) = lincat + return lt - C.RecordValue rrvs -> do - let rrvs' = sortRecordRows rrvs - ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs' ] - return (L.Tuple (map fst ts), Just $ C.RecordType [ C.RecordRow lid lt | (C.RecordRow lid _, (_, Just lt)) <- zip rrvs' ts]) + -- | Lookup lintype for a function's argument + lookupLinTypeArg :: C.FunId -> Int -> Either String C.LinType + lookupLinTypeArg funId argIx = do + fun <- m2e (printf "Cannot find type for: %s" (show funId)) (Map.lookup funId funMap) + let (C.FunDef _ (C.Type args _)) = fun + let (C.TypeBinding _ (C.Type _ (C.TypeApp catId _))) = args !! argIx + lincat <- m2e (printf "Cannot find lincat for: %s" (show catId)) (Map.lookup catId lincatMap) + let (C.LincatDef _ lt) = lincat + return lt - C.TableValue lt trvs -> do - -- group the rows by "left-most" value - let - groupRow :: C.TableRowValue -> C.TableRowValue -> Bool - groupRow (C.TableRow p1 _) (C.TableRow p2 _) = groupPattern p1 p2 + -- Code generation - groupPattern :: C.LinPattern -> C.LinPattern -> Bool - groupPattern p1 p2 = case (p1,p2) of - (C.ParamPattern (C.Param pid1 _), C.ParamPattern (C.Param pid2 _)) -> pid1 == pid2 -- compare only constructors - (C.RecordPattern (C.RecordRow lid1 patt1:_), C.RecordPattern (C.RecordRow lid2 patt2:_)) -> groupPattern patt1 patt2 -- lid1 == lid2 necessarily - _ -> error $ printf "Mismatched patterns in grouping:\n%s\n%s" (show p1) (show p2) + -- | Main code generation function + mkLin :: C.LinDef -> CodeGen (CId, L.LinFun) + mkLin (C.LinDef funId varIds linValue) = do + -- when debug $ trace funId + (lf, _) <- val2lin' linValue --skip memoisation at top level + return (fi2i funId, lf) + where + val2lin :: C.LinValue -> CodeGen (L.LinFun, Maybe C.LinType) + val2lin lv@(C.TableValue _ _) = do + m <- CMS.get + case Map.lookup lv m of + Just r -> return r + Nothing -> do + r <- val2lin' lv + CMS.put (Map.insert lv r m) + return r + val2lin lv = val2lin' lv - grps :: [[C.TableRowValue]] - grps = L.groupBy groupRow trvs + val2lin' :: C.LinValue -> CodeGen (L.LinFun, Maybe C.LinType) + val2lin' lv = case lv of - -- remove one level of depth and recurse - let - handleGroup :: [C.TableRowValue] -> Either String (L.LinFun, Maybe C.LinType) - handleGroup [C.TableRow patt lv] = + C.ConcatValue v1 v2 -> do + (v1',t1) <- val2lin v1 + (v2',t2) <- val2lin v2 + return (L.Concat v1' v2', t1 <|> t2) -- t1 else t2 + + C.LiteralValue ll -> case ll of + C.FloatConstant f -> return (L.Token $ T.pack $ show f, Just C.FloatType) + C.IntConstant i -> return (L.Token $ T.pack $ show i, Just C.IntType) + C.StrConstant s -> return (L.Token $ T.pack s, Just C.StrType) + + C.ErrorValue err -> return (L.Error err, Nothing) + + C.ParamConstant (C.Param pid lvs) -> do + let + collectProjections :: C.LinValue -> CodeGen [L.LinFun] + collectProjections (C.ParamConstant (C.Param pid lvs)) = do + def <- CMS.lift $ lookupParamDef pid + let (C.ParamDef tpid defpids) = def + pidIx <- CMS.lift $ eitherElemIndex pid [ p | C.Param p _ <- defpids ] + rest <- mapM collectProjections lvs + return $ L.Ix (pidIx+1) : concat rest + collectProjections lv = do + (lf,_) <- val2lin lv + return [lf] + lfs <- collectProjections lv + let term = L.Tuple lfs + def <- CMS.lift $ lookupParamDef pid + let (C.ParamDef tpid _) = def + return (term, Just $ C.ParamType (C.ParamTypeId tpid)) + + C.PredefValue (C.PredefId pid) -> case pid of + "BIND" -> return (L.Bind, Nothing) + "SOFT_BIND" -> return (L.Bind, Nothing) + "SOFT_SPACE" -> return (L.Space, Nothing) + "CAPIT" -> return (L.Capit, Nothing) + "ALL_CAPIT" -> return (L.AllCapit, Nothing) + _ -> CMS.lift $ Left $ printf "Unknown predef function: %s" pid + + C.RecordValue rrvs -> do + let rrvs' = sortRecordRows rrvs + ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs' ] + return (L.Tuple (map fst ts), Just $ C.RecordType [ C.RecordRow lid lt | (C.RecordRow lid _, (_, Just lt)) <- zip rrvs' ts]) + + C.TableValue lt trvs -> do + -- group the rows by "left-most" value + let + groupRow :: C.TableRowValue -> C.TableRowValue -> Bool + groupRow (C.TableRow p1 _) (C.TableRow p2 _) = groupPattern p1 p2 + + groupPattern :: C.LinPattern -> C.LinPattern -> Bool + groupPattern p1 p2 = case (p1,p2) of + (C.ParamPattern (C.Param pid1 _), C.ParamPattern (C.Param pid2 _)) -> pid1 == pid2 -- compare only constructors + (C.RecordPattern (C.RecordRow lid1 patt1:_), C.RecordPattern (C.RecordRow lid2 patt2:_)) -> groupPattern patt1 patt2 -- lid1 == lid2 necessarily + _ -> error $ printf "Mismatched patterns in grouping:\n%s\n%s" (show p1) (show p2) + + grps :: [[C.TableRowValue]] + grps = L.groupBy groupRow trvs + + -- remove one level of depth and recurse + let + handleGroup :: [C.TableRowValue] -> CodeGen (L.LinFun, Maybe C.LinType) + handleGroup [C.TableRow patt lv] = + case reducePattern patt of + Just patt' -> do + (lf,lt) <- handleGroup [C.TableRow patt' lv] + return (L.Tuple [lf],lt) + Nothing -> val2lin lv + handleGroup rows = do + let rows' = map reduceRow rows + val2lin (C.TableValue lt rows') -- lt is wrong here, but is unused + + reducePattern :: C.LinPattern -> Maybe C.LinPattern + reducePattern patt = + case patt of + C.ParamPattern (C.Param _ []) -> Nothing + C.ParamPattern (C.Param _ patts) -> Just $ C.ParamPattern (C.Param pid' patts') + where + C.ParamPattern (C.Param pid1 patts1) = head patts + pid' = pid1 + patts' = patts1 ++ tail patts + + C.RecordPattern [] -> Nothing + C.RecordPattern (C.RecordRow lid patt:rrs) -> case reducePattern patt of - Just patt' -> do - (lf,lt) <- handleGroup [C.TableRow patt' lv] - return (L.Tuple [lf],lt) - Nothing -> val2lin lv - handleGroup rows = do - let rows' = map reduceRow rows - val2lin (C.TableValue lt rows') -- lt is wrong here, but is unused + Just patt' -> Just $ C.RecordPattern (C.RecordRow lid patt':rrs) + Nothing -> if null rrs then Nothing else Just $ C.RecordPattern rrs - reducePattern :: C.LinPattern -> Maybe C.LinPattern - reducePattern patt = - case patt of - C.ParamPattern (C.Param _ []) -> Nothing - C.ParamPattern (C.Param _ patts) -> Just $ C.ParamPattern (C.Param pid' patts') - where - C.ParamPattern (C.Param pid1 patts1) = head patts - pid' = pid1 - patts' = patts1 ++ tail patts + _ -> error $ printf "Unhandled pattern in reducing: %s" (show patt) - C.RecordPattern [] -> Nothing - C.RecordPattern (C.RecordRow lid patt:rrs) -> - case reducePattern patt of - Just patt' -> Just $ C.RecordPattern (C.RecordRow lid patt':rrs) - Nothing -> if null rrs then Nothing else Just $ C.RecordPattern rrs + reduceRow :: C.TableRowValue -> C.TableRowValue + reduceRow (C.TableRow patt lv) = + let Just patt' = reducePattern patt + in C.TableRow patt' lv - _ -> error $ printf "Unhandled pattern in reducing: %s" (show patt) + -- ts :: [(L.LinFun, Maybe C.LinType)] + ts <- mapM handleGroup grps - reduceRow :: C.TableRowValue -> C.TableRowValue - reduceRow (C.TableRow patt lv) = - let Just patt' = reducePattern patt - in C.TableRow patt' lv + -- return + let typ = case ts of + (_, Just tst):_ -> Just $ C.TableType lt tst + _ -> Nothing + return (L.Tuple (map fst ts), typ) - -- ts :: [(L.LinFun, Maybe C.LinType)] - ts <- mapM handleGroup grps + -- TODO TuplePattern, WildPattern? - -- return - let typ = case ts of - (_, Just tst):_ -> Just $ C.TableType lt tst - _ -> Nothing - return (L.Tuple (map fst ts), typ) + C.TupleValue lvs -> do + ts <- mapM val2lin lvs + return (L.Tuple (map fst ts), Just $ C.TupleType (map (fromJust.snd) ts)) - -- TODO TuplePattern, WildPattern? + C.VariantValue [] -> return (L.Empty, Nothing) -- TODO Just C.StrType ? + C.VariantValue (vr:_) -> val2lin vr -- NOTE variants not supported, just pick first - C.TupleValue lvs -> do - ts <- mapM val2lin lvs - return (L.Tuple (map fst ts), Just $ C.TupleType (map (fromJust.snd) ts)) + C.VarValue (C.VarValueId (C.Unqual v)) -> do + ix <- CMS.lift $ eitherElemIndex (C.VarId v) varIds + lt <- CMS.lift $ lookupLinTypeArg funId ix + return (L.Argument (ix+1), Just lt) - C.VariantValue [] -> return (L.Empty, Nothing) -- TODO Just C.StrType ? - C.VariantValue (vr:_) -> val2lin vr -- NOTE variants not supported, just pick first + C.PreValue pts df -> do + pts' <- forM pts $ \(pfxs, lv) -> do + (lv', _) <- val2lin lv + return (map T.pack pfxs, lv') + (df', lt) <- val2lin df + return (L.Pre pts' df', lt) - C.VarValue (C.VarValueId (C.Unqual v)) -> do - ix <- eitherElemIndex (C.VarId v) varIds - lt <- lookupLinTypeArg funId ix - return (L.Argument (ix+1), Just lt) + C.Projection v1 lblId -> do + (v1', mtyp) <- val2lin v1 + -- find label index in argument type + let Just (C.RecordType rrs) = mtyp + let rrs' = [ lid | C.RecordRow lid _ <- rrs ] + -- lblIx <- eitherElemIndex lblId rrs' + let + lblIx = case eitherElemIndex lblId rrs' of + Right x -> x + Left _ -> 0 -- corresponds to Prelude.False + -- lookup lintype for record row + let C.RecordRow _ lt = rrs !! lblIx + return (L.Projection v1' (L.Ix (lblIx+1)), Just lt) - C.PreValue pts df -> do - pts' <- forM pts $ \(pfxs, lv) -> do - (lv', _) <- val2lin lv - return (map T.pack pfxs, lv') - (df', lt) <- val2lin df - return (L.Pre pts' df', lt) + C.Selection v1 v2 -> do + (v1', t1) <- val2lin v1 + (v2', t2) <- val2lin v2 + let Just (C.TableType t11 t12) = t1 -- t11 == t2 + return (L.Projection v1' v2', Just t12) - C.Projection v1 lblId -> do - (v1', mtyp) <- val2lin v1 - -- find label index in argument type - let Just (C.RecordType rrs) = mtyp - let rrs' = [ lid | C.RecordRow lid _ <- rrs ] - -- lblIx <- eitherElemIndex lblId rrs' - let - lblIx = case eitherElemIndex lblId rrs' of - Right x -> x - Left _ -> 0 -- corresponds to Prelude.False - -- lookup lintype for record row - let C.RecordRow _ lt = rrs !! lblIx - return (L.Projection v1' (L.Ix (lblIx+1)), Just lt) + -- C.CommentedValue cmnt lv -> val2lin lv + C.CommentedValue cmnt lv -> case cmnt of + "impossible" -> val2lin lv >>= \(_, typ) -> return (L.Empty, typ) + _ -> val2lin lv - C.Selection v1 v2 -> do - (v1', t1) <- val2lin v1 - (v2', t2) <- val2lin v2 - let Just (C.TableType t11 t12) = t1 -- t11 == t2 - return (L.Projection v1' v2', Just t12) + v -> CMS.lift $ Left $ printf "val2lin not implemented for: %s" (show v) - -- C.CommentedValue cmnt lv -> val2lin lv - C.CommentedValue cmnt lv -> case cmnt of - "impossible" -> val2lin lv >>= \(_, typ) -> return (L.Empty, typ) - _ -> val2lin lv - - v -> Left $ printf "val2lin not implemented for: %s" (show v) - - unless (null $ lefts es) (raise $ unlines (lefts es)) + -- Invoke code generation + let e = flip CMS.evalStateT Map.empty $ mapM mkLin lindefs + case e of + Left err -> raise err + Right lins -> do let maybeOptimise = if debug then id else extractStrings let concr = maybeOptimise $ L.Concrete { - L.toks = IntMap.empty, - L.lins = lins + L.toks = IntMapBuilder.emptyIntMap, + L.lins = Map.fromList lins } return (mdi2i modId, concr) +type CodeGen a = CMS.StateT (Map.Map C.LinValue (L.LinFun, Maybe C.LinType)) (Either String) a + -- | Remove ParamAliasDefs by inlining their definitions inlineParamAliases :: [C.ParamDef] -> [C.ParamDef] inlineParamAliases defs = if null aliases then defs else map rp' pdefs diff --git a/src/compiler/GF/Data/IntMapBuilder.hs b/src/compiler/GF/Data/IntMapBuilder.hs index 77be56b47..b8a1c922a 100644 --- a/src/compiler/GF/Data/IntMapBuilder.hs +++ b/src/compiler/GF/Data/IntMapBuilder.hs @@ -23,6 +23,10 @@ empty = IMB { valMap = HashMap.empty } +-- | An empty IntMap +emptyIntMap :: IntMap a +emptyIntMap = IntMap.empty + -- | Lookup a value lookup :: (Eq a, Hashable a) => a -> IMB a -> Maybe Int lookup a IMB { valMap = vm } = HashMap.lookup a vm diff --git a/testsuite/lpgf/README.md b/testsuite/lpgf/README.md index acfda2a31..b2738d51f 100644 --- a/testsuite/lpgf/README.md +++ b/testsuite/lpgf/README.md @@ -86,6 +86,132 @@ stack exec -- hp2ps -c lpgf-bench.hp && open lpgf-bench.ps - http://book.realworldhaskell.org/read/profiling-and-optimization.html - https://wiki.haskell.org/Performance + +### Honing in + +``` +stack build --test --bench --no-run-tests --no-run-benchmarks && +stack bench --benchmark-arguments "compile lpgf testsuite/lpgf/phrasebook/PhrasebookFre.gf +RTS -T -RTS" +``` + +**Baseline PGF** +- compile: 1.600776s +- size: 2.88 MB Phrasebook.pgf +Max memory: 328.20 MB + +**Baseline LPGF = B** +- compile: 12.401099s +- size: 3.01 MB Phrasebook.lpgf +Max memory: 1.33 GB + +**Baseline LPGF String** +- compile: 12.124689s +- size: 3.01 MB Phrasebook.lpgf +Max memory: 1.34 GB + +**B -extractStrings** +- compile: 13.822735s +- size: 5.78 MB Phrasebook.lpgf +Max memory: 1.39 GB + +**B -cleanupRecordFields** +- compile: 13.670776s +- size: 3.01 MB Phrasebook.lpgf +Max memory: 1.48 GB + +**No generation at all = E** +- compile: 0.521001s +- size: 3.27 KB Phrasebook.lpgf +Max memory: 230.69 MB + +**+ Concat, Literal, Error, Predef, Tuple, Variant, Commented** +- compile: 1.503594s +- size: 3.27 KB Phrasebook.lpgf +Max memory: 395.31 MB + +**+ Var, Pre, Selection** +- compile: 1.260184s +- size: 3.28 KB Phrasebook.lpgf +Max memory: 392.17 MB + +**+ Record** +- compile: 1.659233s +- size: 7.07 KB Phrasebook.lpgf +Max memory: 397.41 MB + +**+ Projection = X** +- compile: 1.446217s +- size: 7.94 KB Phrasebook.lpgf +Max memory: 423.62 MB + +**X + Param** +- compile: 2.073838s +- size: 10.82 KB Phrasebook.lpgf +Max memory: 619.71 MB + +**X + Table** +- compile: 11.26558s +- size: 2.48 MB Phrasebook.lpgf +Max memory: 1.15 GB + +### Repeated terms in compilation + +**Param and Table** + +| Concr | Total | Unique | Perc | +|:--------------|-------:|-------:|-----:| +| PhrasebookEng | 8673 | 1724 | 20% | +| PhrasebookSwe | 14802 | 2257 | 15% | +| PhrasebookFin | 526225 | 4866 | 1% | + +**Param** + +| Concr | Total | Unique | Perc | +|:--------------|-------:|-------:|-----:| +| PhrasebookEng | 3211 | 78 | 2% | +| PhrasebookSwe | 7567 | 69 | 1% | +| PhrasebookFin | 316355 | 310 | 0.1% | + +**Table** + +| Concr | Total | Unique | Perc | +|:--------------|-------:|-------:|-----:| +| PhrasebookEng | 5470 | 1654 | 30% | +| PhrasebookSwe | 7243 | 2196 | 30% | +| PhrasebookFin | 209878 | 4564 | 2% | + +### After impelementing state monad for table memoisation + +**worse!** +- compile: 12.55848s +- size: 3.01 MB Phrasebook.lpgf +Max memory: 2.25 GB + +**Params** + +| Concr | Total | Misses | Perc | +|:--------------|-------:|-------:|------:| +| PhrasebookEng | 3211 | 72 | 2% | +| PhrasebookSwe | 7526 | 61 | 1% | +| PhrasebookFin | 135268 | 333 | 0.2% | +| PhrasebookFre | 337102 | 76 | 0.02% | + +**Tables** + +| Concr | Total | Misses | Perc | +|:--------------|------:|-------:|-----:| +| PhrasebookEng | 3719 | 3170 | 85% | +| PhrasebookSwe | 4031 | 3019 | 75% | +| PhrasebookFin | 36875 | 21730 | 59% | +| PhrasebookFre | 41397 | 32967 | 80% | + +Conclusions: +- map itself requires more memory than acual compilation +- lookup is also as also as actual compilation + +Tried HashMap (deriving Hashable for LinValue), no inprovement. +Using show on LinValue for keys is incredibly slow. + # Notes on compilation ## 1 (see unittests/Params4)