shithub: MicroHs

Info  •  Files  •  Log  •  Branches

Add functions to force evaluation, and use that for timing.

--- a/lib/Data/List.hs

+++ b/lib/Data/List.hs

@@ -300,3 +300,7 @@

 last [] = error "last: []"

 last [x] = x

 last (_:xs) = last xs

+

+forceList :: forall a . (a -> ()) -> [a] -> ()

+forceList _ [] = ()

+forceList f (a:as) = case f a of { () -> forceList f as }

--- a/lib/Text/String.hs

+++ b/lib/Text/String.hs

@@ -116,3 +116,7 @@

 padLeft :: Int -> String -> String

 padLeft n s = replicate (n - length s) ' ' ++ s

+

+forceString :: String -> ()

+forceString [] = ()

+forceString (c:cs) = c `primSeq` forceString cs

--- a/src/Compat.hs

+++ b/src/Compat.hs

@@ -152,3 +152,14 @@

 deleteAllsBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]

 deleteAllsBy eq = foldl (flip (deleteAllBy eq))

+

+forceString :: String -> ()

+forceString [] = ()

+forceString (c:cs) = c `seq` forceString cs

+

+forceList :: forall a . (a -> ()) -> [a] -> ()

+forceList _ [] = ()

+forceList f (a:as) = case f a of { () -> forceList f as }

+

+writeSerialized :: FilePath -> a -> IO ()

+writeSerialized _ _ = error "writeSerialized"

--- a/src/MicroHs/Desugar.hs

+++ b/src/MicroHs/Desugar.hs

@@ -3,7 +3,7 @@

 {-# OPTIONS_GHC -Wno-type-defaults -Wno-incomplete-uni-patterns -Wno-unused-imports -Wno-dodgy-imports #-}

 module MicroHs.Desugar(

   desugar,

-  LDef, showLDefs

+  LDef, showLDefs, forceLDef

   ) where

 import Prelude --Xhiding(showList)

 import Data.Char

@@ -488,3 +488,7 @@

     (i1:i2:_) : _ ->

       errorMessage (getSLocIdent i1) $ "Duplicate " ++ showIdent i1 ++ " " ++ showSLoc (getSLocIdent i2)

     _ -> undefined

+

+forceLDef :: LDef -> ()

+forceLDef (i, e) = case forceIdent i of { () -> forceExp e }

+

--- a/src/MicroHs/Exp.hs

+++ b/src/MicroHs/Exp.hs

@@ -8,13 +8,14 @@

   PrimOp,

   encodeString,

   app2, cCons, cNil, cFlip,

-  allVarsExp, freeVars

+  allVarsExp, freeVars,

+  forceExp

   ) where

 import Prelude

 import Data.Char

 import Data.List

 import MicroHs.Ident

-import MicroHs.Expr --X(Lit(..), showLit, eqLit)

+import MicroHs.Expr --X(Lit(..), showLit, eqLit, forceLit)

 --Ximport Compat

 --import Debug.Trace

@@ -33,6 +34,12 @@

 eqExp (Lam i1 e1) (Lam i2 e2) = eqIdent i1 i2 && eqExp e1 e2

 eqExp (Lit l1) (Lit l2) = eqLit l1 l2

 eqExp _ _ = False

+

+forceExp :: Exp -> ()

+forceExp (Var i) = forceIdent i

+forceExp (App f a) = case forceExp f of { () -> forceExp a }

+forceExp (Lam i e) = case forceIdent i of { () -> forceExp e }

+forceExp (Lit l) = forceLit l

 data MaybeApp = NotApp | IsApp Exp Exp

--- a/src/MicroHs/Expr.hs

+++ b/src/MicroHs/Expr.hs

@@ -6,7 +6,7 @@

   EDef(..), showEDefs,

   Expr(..), showExpr,

   Listish(..),

-  Lit(..), showLit, eqLit,

+  Lit(..), showLit, eqLit, forceLit,

   EBind(..),

   Eqn(..),

   EStmt(..),

@@ -134,6 +134,13 @@

 eqLit (LPrim x) (LPrim y) = eqString x y

 eqLit (LForImp x) (LForImp y) = eqString x y

 eqLit _         _         = False

+

+forceLit :: Lit -> ()

+forceLit (LInt i) = seq i ()

+forceLit (LChar c) = seq c ()

+forceLit (LStr s) = forceString s

+forceLit (LPrim s) = forceString s

+forceLit (LForImp s) = forceString s

 type ECaseArm = (EPat, EAlts)

--- a/src/MicroHs/Ident.hs

+++ b/src/MicroHs/Ident.hs

@@ -5,6 +5,7 @@

   Ident(..),

   mkIdent, mkIdentLoc, unIdent, eqIdent, leIdent, qualIdent, showIdent, getSLocIdent, setSLocIdent,

   mkIdentSLoc,

+  forceIdent,

   isLower_, isIdentChar, isOperChar, isConIdent,

   unQualString,

   SLoc(..), noSLoc, showSLoc

@@ -83,3 +84,7 @@

 showSLoc (SLoc fn l c) =

   if null fn then "no location" else

   showString fn ++ ": " ++ "line " ++ showInt l ++ ", col " ++ showInt c

+

+-- Does not force location

+forceIdent :: Ident -> ()

+forceIdent (Ident _ s) = forceString s

--- a/src/MicroHs/Main.hs

+++ b/src/MicroHs/Main.hs

@@ -74,7 +74,7 @@

   t1 <- getTimeMilli

   let

     dsn = [ (n, compileOpt e) | (n, e) <- ds ]

-  putStr $ drop 1000000 $ showLDefs dsn

+  () <- return (forceList forceLDef dsn)

   t2 <- getTimeMilli

   when (verbose flags > 0) $

     putStrLn $ "combinator conversion " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"

-- 

⑨