msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

-Wall; no warnings

Browse Source
This commit is contained in:
crumbtoo
2023-12-04 14:50:50 -07:00
parent 5c3b7c2c30
commit cb6321fbf8
4 changed files with 93 additions and 83 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
app/Main.hs
View File

@@ -11,7 +11,6 @@ import System.Exit (exitSuccess)
import Core import Core
import TI import TI
import GM import GM
import Lens.Micro
import Lens.Micro.Mtl import Lens.Micro.Mtl
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------

2
rlp.cabal
View File

@@ -14,7 +14,7 @@ extra-doc-files: README.md
-- extra-source-files: -- extra-source-files:
common warnings common warnings
-- ghc-options: -Wall ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
library library
import: warnings import: warnings

2
src/Core/Syntax.hs
View File

@@ -43,6 +43,8 @@ infixl 2 :$
pattern (:$) :: Expr -> Expr -> Expr pattern (:$) :: Expr -> Expr -> Expr
pattern f :$ x = App f x pattern f :$ x = App f x
{-# COMPLETE Binding :: Binding #-}
{-# COMPLETE (:=) :: Binding #-}
data Binding = Binding Name Expr data Binding = Binding Name Expr
deriving (Show, Lift, Eq) deriving (Show, Lift, Eq)

171
src/GM.hs
View File

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