exa/prlg
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

fix minor stuff

Browse source
This commit is contained in:
Mirek Kratochvil 2022-11-26 20:15:09 +01:00
parent d13fc60bf3
commit 32f6fe0291
2 changed files with 15 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
app/Builtins.hs
View file

@ -110,8 +110,7 @@ retractall = do
{- adding the builtins -} {- adding the builtins -}
addOp op = modify $ \s -> s {ops = op : ops s} addOp op = modify $ \s -> s {ops = op : ops s}
addClause struct code = do addClause struct code =
lift . outputStrLn $ "Adding " ++ show struct ++ " with code " ++ show code
modify $ \s -> modify $ \s ->
s {defs = M.alter (Just . maybe [code] (\hs -> code : hs)) struct $ defs s} s {defs = M.alter (Just . maybe [code] (\hs -> code : hs)) struct $ defs s}

24
app/Compiler.hs
View file

@ -1,7 +1,6 @@
module Compiler where module Compiler where
import Data.Char (isUpper) import Data.Char (isUpper)
import Data.Containers.ListUtils (nubOrd)
import qualified Data.Map as M import qualified Data.Map as M
import Code (Code, Datum(..), Heap, Instr(..), heapStruct) import Code (Code, Datum(..), Heap, Instr(..), heapStruct)
@ -12,10 +11,10 @@ varname ('_':_) = True
varname (c:_) = isUpper c varname (c:_) = isUpper c
varname _ = False varname _ = False
varIds :: PrlgInt -> [Int] varOccurs :: PrlgInt -> M.Map Int Int
varIds (CallI _ xs) = nubOrd $ concatMap varIds xs varOccurs (CallI _ xs) = M.unionsWith (+) $ map varOccurs xs
varIds (VarI idx _) = [idx] varOccurs (VarI idx _) = M.singleton idx 1
varIds _ = [] varOccurs _ = M.empty
variablizePrlg :: Int -> StrTable -> PrlgInt -> PrlgInt variablizePrlg :: Int -> StrTable -> PrlgInt -> PrlgInt
variablizePrlg void (StrTable _ _ itos) = go variablizePrlg void (StrTable _ _ itos) = go
@ -26,16 +25,22 @@ variablizePrlg void (StrTable _ _ itos) = go
| varname (itos M.! i) = VarI i i | varname (itos M.! i) = VarI i i
| otherwise = LiteralI i | otherwise = LiteralI i
renumVars :: [(Int, Int)] -> PrlgInt -> PrlgInt renumVars :: (Int -> Maybe PrlgInt) -> PrlgInt -> PrlgInt
renumVars rename = go renumVars rename = go
where where
go (CallI id ps) = CallI id $ map go ps go (CallI id ps) = CallI id $ map go ps
go (VarI idx i) go (VarI idx i)
| Just idx' <- lookup idx rename = VarI idx' i | Just new <- rename idx = new
go x = x go x = x
squashVars :: PrlgInt -> PrlgInt squashVars :: PrlgInt -> PrlgInt
squashVars x = renumVars (zip (varIds x) [1 ..]) x squashVars x =
let occurs = M.assocs (varOccurs x)
m' =
M.fromList $
[(idx, VoidI) | (idx, n) <- occurs, n <= 1] ++
[(idx, VarI idx' 0) | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
in renumVars (m' M.!?) x
compileGoals :: Id -> Int -> PrlgInt -> [Code] compileGoals :: Id -> Int -> PrlgInt -> [Code]
compileGoals andop cut = go' compileGoals andop cut = go'
@ -65,8 +70,7 @@ seqGoals ([Cut]:xs) = [Cut] ++ seqGoals xs
seqGoals (x:xs) = [Goal] ++ x ++ [Call] ++ seqGoals xs seqGoals (x:xs) = [Goal] ++ x ++ [Call] ++ seqGoals xs
heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt
heapStructPrlgInt heaperr heap ref = heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
squashVars <$> heapStruct atom struct hrec heap ref
where where
atom (Atom s) = pure $ LiteralI s atom (Atom s) = pure $ LiteralI s
atom VoidRef = pure $ VoidI atom VoidRef = pure $ VoidI