From cb6321fbf8ce03e939b7afe828368a8284c01e0c Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Mon, 4 Dec 2023 14:50:50 -0700 Subject: [PATCH] -Wall; no warnings --- app/Main.hs | 1 - rlp.cabal | 2 +- src/Core/Syntax.hs | 2 + src/GM.hs | 171 ++++++++++++++++++++++++--------------------- 4 files changed, 93 insertions(+), 83 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 4bfcdd5..f18c03f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,7 +11,6 @@ import System.Exit (exitSuccess) import Core import TI import GM -import Lens.Micro import Lens.Micro.Mtl ---------------------------------------------------------------------------------- diff --git a/rlp.cabal b/rlp.cabal index 4aeaa36..00ed930 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -14,7 +14,7 @@ extra-doc-files: README.md -- extra-source-files: common warnings - -- ghc-options: -Wall + ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds library import: warnings diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index 03d2f6f..62ee607 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -43,6 +43,8 @@ infixl 2 :$ pattern (:$) :: Expr -> Expr -> Expr pattern f :$ x = App f x +{-# COMPLETE Binding :: Binding #-} +{-# COMPLETE (:=) :: Binding #-} data Binding = Binding Name Expr deriving (Show, Lift, Eq) diff --git a/src/GM.hs b/src/GM.hs index c581284..95aa154 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -11,7 +11,7 @@ module GM where ---------------------------------------------------------------------------------- import Data.Default.Class -import Data.List (mapAccumL, intersperse) +import Data.List (mapAccumL) import Data.Maybe (fromMaybe) import Data.Tuple (swap) import Lens.Micro @@ -20,8 +20,8 @@ import Text.Printf import Text.PrettyPrint hiding ((<>)) import Text.PrettyPrint.HughesPJ (maybeParens) import Data.Foldable (traverse_) -import Control.Arrow ((>>>)) import System.IO (Handle, hPutStrLn) +import Data.String (IsString) import Data.Heap import Core ---------------------------------------------------------------------------------- @@ -126,46 +126,46 @@ isFinal :: GmState -> Bool isFinal st = null $ st ^. gmCode step :: GmState -> GmState -step st = case head (st ^. gmCode) of - Unwind -> unwindI st - PushGlobal n -> pushGlobalI n st - PushInt n -> pushIntI n st - Push n -> pushI n st - MkAp -> mkApI st - Slide n -> slideI n st - Pop n -> popI n st - Update n -> updateI n st - Alloc n -> allocI n st - Eval -> evalI st - Neg -> negI st - Add -> addI st - Sub -> subI st - Mul -> mulI st - Div -> divI st +step state = case head (state ^. gmCode) of + Unwind -> unwindI state + PushGlobal n -> pushGlobalI n state + PushInt n -> pushIntI n state + Push n -> pushI n state + MkAp -> mkApI state + Slide n -> slideI n state + Pop n -> popI n state + Update n -> updateI n state + Alloc n -> allocI n state + Eval -> evalI state + Neg -> negI state + Add -> addI state + Sub -> subI state + Mul -> mulI state + Div -> divI state where pushGlobalI :: Name -> GmState -> GmState pushGlobalI k st = st - & gmCode %~ drop 1 + & advanceCode & gmStack .~ s' where s = st ^. gmStack m = st ^. gmEnv s' = a : s - a = fromMaybe (error $ "undefined var: " <> show k) - $ lookup k m + a = lookup k m + & fromMaybe (error $ "undefined var: " <> show k) -- Extension Rules 1,2 (sharing) pushIntI :: Int -> GmState -> GmState pushIntI n st = case lookup n' m of Just a -> st - & gmCode %~ drop 1 + & advanceCode & gmStack .~ s' where s' = a : s Nothing -> st - & gmCode %~ drop 1 + & advanceCode & gmStack .~ s' & gmHeap .~ h' & gmEnv .~ m' @@ -184,7 +184,7 @@ step st = case head (st ^. gmCode) of -- Core Rule 2. (no sharing) -- pushIntI :: Int -> GmState -> GmState -- pushIntI n st = st - -- & gmCode %~ drop 1 + -- & advanceCode -- & gmStack .~ s' -- & gmHeap .~ h' -- & gmStats . stsAllocations %~ succ @@ -197,7 +197,7 @@ step st = case head (st ^. gmCode) of mkApI :: GmState -> GmState mkApI st = st - & gmCode %~ drop 1 + & advanceCode & gmStack .~ s' & gmHeap .~ h' -- record the application we allocated @@ -213,10 +213,9 @@ step st = case head (st ^. gmCode) of -- the stack. pushI :: Int -> GmState -> GmState pushI n st = st - & gmCode %~ drop 1 + & advanceCode & gmStack %~ (a:) where - h = st ^. gmHeap s = st ^. gmStack a = s !! n @@ -230,7 +229,7 @@ step st = case head (st ^. gmCode) of -- 3: f x y slideI :: Int -> GmState -> GmState slideI n st = st - & gmCode %~ drop 1 + & advanceCode & gmStack .~ s' where (a:s) = st ^. gmStack @@ -238,7 +237,7 @@ step st = case head (st ^. gmCode) of updateI :: Int -> GmState -> GmState updateI n st = st - & gmCode %~ drop 1 + & advanceCode & gmStack .~ s & gmHeap .~ h' where @@ -249,12 +248,12 @@ step st = case head (st ^. gmCode) of popI :: Int -> GmState -> GmState popI n st = st - & gmCode %~ drop 1 + & advanceCode & gmStack %~ drop n allocI :: Int -> GmState -> GmState allocI n st = st - & gmCode %~ drop 1 + & advanceCode & gmStack .~ s' & gmHeap .~ h' where @@ -293,31 +292,30 @@ step st = case head (st ^. gmCode) of -- the complex heart of the G-machine unwindI :: GmState -> GmState unwindI st = case hLookupUnsafe a h of - NNum n -> st + NNum _ -> st & gmCode .~ i' & gmStack .~ s' & gmDump .~ d' where - s = st ^. gmStack (i',s',d') = case st ^. gmDump of -- if the dump is non-empty, restore the instruction -- queue and stack, and pop the dump ((ii,ss):d) -> (ii,a:ss,d) -- if the dump is empty, clear the instruction queue and -- leave the stack as is - [] -> ([], s, []) + [] -> ([], s, []) - NAp f x -> st + NAp f _ -> st -- leave the Unwind instr; continue unwinding & gmStack %~ (f:) - NGlobal k c + NGlobal k _ | n < k -> st - & gmCode .~ i - & gmStack .~ s - & gmDump .~ d + & gmCode .~ i' + & gmStack .~ s' + & gmDump .~ d' where - ((i,s) : d) = st ^. gmDump + ((i',s') : d') = st ^. gmDump n = st ^. gmStack & length -- assumes length s < d (i.e. enough args have been supplied) NGlobal n c -> st @@ -330,22 +328,26 @@ step st = case head (st ^. gmCode) of args = getArgs $ take (n+1) s getArgs :: Stack -> [Addr] + getArgs [] = [] getArgs (_:ss) = fmap arg ss where arg (hViewUnsafe h -> NAp _ x) = x + arg (hViewUnsafe h -> _) = + error "expected application" -- follow indirection - NInd a -> st + NInd a' -> st -- leave the Unwind instr; continue unwinding. -- follow the indirection; replace the address on the -- stack with the pointee - & gmStack . _head .~ a + & gmStack . _head .~ a' + + _ -> error "invalid state" where s = st ^. gmStack a = head s h = st ^. gmHeap - -- TODO: this desperately needs documentation primitive1 :: (GmState -> b -> GmState) -- boxing function -> (Addr -> GmState -> a) -- unboxing function @@ -359,9 +361,7 @@ primitive1 box unbox f st & advanceCode & gmStats . stsPrimReductions %~ succ where - putNewStack = gmStack .~ s (a:s) = st ^. gmStack - r = box (putNewStack st) (f (unbox a st)) -- TODO: this desperately needs documentation primitive2 :: (GmState -> b -> GmState) -- boxing function @@ -397,6 +397,10 @@ unboxInt a st = case hLookup a h of advanceCode :: GmState -> GmState advanceCode = gmCode %~ drop 1 +pop :: [a] -> [a] +pop (_:xs) = xs +pop [] = [] + ---------------------------------------------------------------------------------- compile :: Program -> GmState @@ -413,7 +417,8 @@ compiledPrims :: [CompiledSC] compiledPrims = [ ("whnf#", 1, [Push 0, Eval, Update 1, Pop 1, Unwind]) -- , unop "negate#" Neg - , ("negate#", 1, [Push 0, Eval, Neg, Update 1, Pop 1, Unwind]) + -- , ("negate#", 1, [Push 0, Eval, Neg, Update 1, Pop 1, Unwind]) + , unop "negate#" Neg , binop "+#" Add , binop "-#" Sub , binop "*#" Mul @@ -458,7 +463,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs n = fromMaybe (error $ "undeclared var: " <> k) $ lookup k g domain = fmap fst g - compileC g (IntE n) = [PushInt n] + compileC _ (IntE n) = [PushInt n] -- >> [ref/compileC] compileC g (App f x) = compileC g x @@ -493,12 +498,14 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs body = compileC g' e compileBinder :: (Binding, Int) -> Code - compileBinder (k := v, a) = compileC g' v <> [Update a] + compileBinder (_ := v, a) = compileC g' v <> [Update a] + + compileC _ _ = error "yet to be implemented!" -- compile an expression in a strict context such that a pointer to the -- expression is left on top of the stack in WHNF compileE :: Env -> Expr -> Code - compileE g (IntE n) = [PushInt n] + compileE _ (IntE n) = [PushInt n] compileE g (Let NonRec bs e) = -- we use compileE instead of compileC mconcat binders <> compileE g' e <> [Slide d] @@ -530,7 +537,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs -- we use compileE instead of compileC compileBinder :: (Binding, Int) -> Code - compileBinder (k := v, a) = compileC g' v <> [Update a] + compileBinder (_ := v, a) = compileC g' v <> [Update a] -- special cases for prim functions compileE g ("negate#" :$ a) = compileE g a <> [Neg] @@ -556,7 +563,6 @@ qquotes d = "`" <> d <> "'" showStats :: Stats -> Doc showStats sts = "==== Stats ============" $$ stats where - info = nest pprTabstop stats = text $ printf "Reductions : %5d\n\ \Prim Reductions : %5d\n\ @@ -569,9 +575,10 @@ showStats sts = "==== Stats ============" $$ stats showState :: GmState -> Doc showState st = vcat - [ "==== GmState " <> int stnum <> " ====" + [ "==== GmState " <> int stnum <> " " + <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=') , "-- Next instructions -------" - , info $ showNextCode c + , info $ showCodeShort c , "-- Stack -------------------" , info $ showStack st , "-- Heap --------------------" @@ -586,12 +593,21 @@ showState st = vcat -- indent data info = nest pprTabstop -showNextCode :: Code -> Doc -showNextCode c = brackets c' +showCodeShort :: Code -> Doc +showCodeShort c = braces c' where - c' | length c > 3 = list (showInstr <$> take 3 c) <> ", ..." + c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..." | otherwise = list (showInstr <$> c) + list = hcat . punctuate "; " + +showStackShort :: Stack -> Doc +showStackShort s = brackets s' + where + -- no access to heap, otherwise we'd use showNodeAt + s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..." + | otherwise = list (showEntry <$> s) list = hcat . punctuate ", " + showEntry = text . show showStack :: GmState -> Doc showStack st = vcat $ uncurry showEntry <$> si @@ -611,7 +627,6 @@ showStack st = vcat $ uncurry showEntry <$> si showDump :: GmState -> Doc showDump st = vcat $ uncurry showEntry <$> di where - h = st ^. gmHeap d = st ^. gmDump di = [0..] `zip` d @@ -619,8 +634,10 @@ showDump st = vcat $ uncurry showEntry <$> di w = maxWidth (fst <$> di) showEntry :: Int -> (Code, Stack) -> Doc - showEntry n (c,s) = showIndex n - <> nest pprTabstop (showCode c) + showEntry n (c,s) = showIndex n <> nest pprTabstop entry + where + entry = ("Stack : " <> showCodeShort c) + $$ ("Code : " <> showStackShort s) padInt :: Int -> Int -> Doc padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n @@ -632,14 +649,13 @@ digitalWidth :: Int -> Int digitalWidth = length . show showHeap :: GmState -> Doc -showHeap st = vcat $ showEntry <$> addresses h +showHeap st = vcat $ showEntry <$> addrs where - digitalWidth = length . show - maxWidth = digitalWidth $ maximum (addresses h) - showAddr n = pad <> int n <> ": " - where pad = text (replicate (maxWidth - digitalWidth n) ' ') + showAddr n = padInt w n <> ": " + w = maxWidth addrs h = st ^. gmHeap + addrs = addresses h showEntry :: Addr -> Doc showEntry a = showAddr a <> showNodeAt st a @@ -650,16 +666,16 @@ showNodeAt = showNodeAtP 0 showNodeAtP :: Int -> GmState -> Addr -> Doc showNodeAtP p st a = case hLookup a h of Just (NNum n) -> int n <> "#" - Just (NGlobal d c) -> text name + Just (NGlobal _ _) -> text name where g = st ^. gmEnv - name = fromMaybe "" $ lookup a (swap <$> g) + name = fromMaybe errTxtInvalidAddress $ lookup a (swap <$> g) Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x where pprec = maybeParens (p > 0) - Just (NInd a) -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a + Just (NInd a') -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a' where pprec = maybeParens (p > 0) Just NUninitialised -> "" - Nothing -> "" + Nothing -> errTxtInvalidAddress where h = st ^. gmHeap showSc :: GmState -> (Name, Addr) -> Doc @@ -668,7 +684,12 @@ showSc st (k,a) = "Supercomb " <> qquotes (text k) <> colon where code = case hLookup a (st ^. gmHeap) of Just (NGlobal _ c) -> showCode c - Nothing -> "" + Just _ -> errTxtInvalidObject + Nothing -> errTxtInvalidAddress + +errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a +errTxtInvalidObject = "" +errTxtInvalidAddress = "" showCode :: Code -> Doc showCode c = "Code" <+> braces instrs @@ -677,15 +698,3 @@ showCode c = "Code" <+> braces instrs showInstr :: Instr -> Doc showInstr i = text $ show i -test = GmState c s d h'' g sts - where - c = [Push 4, Push 5, Slide 2, Unwind] - s = [a0,a1,a2] - (h,a0) = alloc mempty $ NGlobal 2 [Push 2,Push 3,MkAp,Slide 2,Unwind] - (h',a1) = alloc h $ NNum 4 - (h'',a2) = alloc h' $ NAp a0 a1 - g = [ ("f", a0) - ] - d = [] - sts = def -