From 2f8b98d4b5f4ed62a49473cf9807cb7334e90e51 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Sun, 2 Jun 2013 21:51:00 -0400 Subject: [PATCH] Make BackendDefn 'constants' a function Rather than a guaranteed finite map. While here, make NoBackend agree more with the Python backend and sort the lists of primitives. --- src/Dyna/Backend/BackendDefn.hs | 2 +- src/Dyna/Backend/NoBackend.hs | 74 ++++++++++++++------------ src/Dyna/Backend/Python/Backend.hs | 85 ++++++++++++++++-------------- src/Dyna/Main/Driver.hs | 3 +- 4 files changed, 86 insertions(+), 78 deletions(-) diff --git a/src/Dyna/Backend/BackendDefn.hs b/src/Dyna/Backend/BackendDefn.hs index cefb6d4..786432b 100644 --- a/src/Dyna/Backend/BackendDefn.hs +++ b/src/Dyna/Backend/BackendDefn.hs @@ -36,7 +36,7 @@ data Backend = forall bs . Backend -- | Any constants made available by this backend. -- -- XXX - , be_constants :: S.Set DFunctAr + , be_constants :: DFunctAr -> Bool -- | Debugging hook to render bits of DOpAMine which -- are "backend-specific" diff --git a/src/Dyna/Backend/NoBackend.hs b/src/Dyna/Backend/NoBackend.hs index 5202fb6..818a7af 100644 --- a/src/Dyna/Backend/NoBackend.hs +++ b/src/Dyna/Backend/NoBackend.hs @@ -12,6 +12,7 @@ module Dyna.Backend.NoBackend (noBackend) where import Control.Lens import Control.Monad +import qualified Data.Maybe as MA import qualified Data.Map as M import qualified Data.Set as S import Dyna.Analysis.ANF @@ -35,7 +36,7 @@ import qualified Debug.Trace as XT noBackend :: Backend noBackend = Backend { be_builtin = primPossible - , be_constants = M.keysSet primOps -- XXX + , be_constants = MA.isJust . primOps -- XXX , be_debug_dop_iter = \_ _ _ _ _ -> empty , be_driver = driver } @@ -50,41 +51,46 @@ data PrimOp = PO , po_bs :: forall e . Doc e } -primOps :: M.Map DFunctAr [QMode (NIX DFunct)] -- XXX ,UMode -primOps = M.fromList - [ let ar = 2 in ( ("+" ,ar) , [miaod ar Det ] - ++ opinvd ar Det ) - , let ar = 2 in ( ("-" ,ar) , [miaod ar Det ] - ++ opinvd ar Det ) - , let ar = 2 in ( ("*" ,ar) , [miaod ar Det ] - ++ opinvd ar DetSemi ) - , let ar = 2 in ( ("/" ,ar) , [miaod ar DetSemi ] - ++ opinvd ar DetSemi ) - , let ar = 2 in ( ("^" ,ar) , [miaod ar Det ] ) - , let ar = 2 in ( ("&" ,ar) , [miaod ar Det ] ) - , let ar = 2 in ( ("|" ,ar) , [miaod ar Det ] ) - , let ar = 2 in ( ("%" ,ar) , [miaod ar Det ] ) - , let ar = 2 in ( ("**" ,ar) , [miaod ar Det ] ) - , let ar = 2 in ( ("<" ,ar) , [miaod ar Det ] ) - , let ar = 2 in ( ("<=" ,ar) , [miaod ar Det ] ) - , let ar = 2 in ( (">" ,ar) , [miaod ar Det ] ) - , let ar = 2 in ( (">=" ,ar) , [miaod ar Det ] ) - , let ar = 2 in ( ("=" ,ar) , [miaod ar Det ] ) - -- Unary boolean negation - , let ar = 1 in ( ("!" ,ar) , [miaod ar Det ] ) - -- Unary numeric negation - , let ar = 1 in ( ("-" ,ar) , [miaod ar Det ] ) - , let ar = 1 in ( ("mod" ,ar) , [miaod ar Det ] ) - , let ar = 1 in ( ("abs" ,ar) , [miaod ar Det ] ) - , let ar = 1 in ( ("log" ,ar) , [miaod ar Det ] ) - , let ar = 1 in ( ("exp" ,ar) , [miaod ar Det ] ) - , let ar = 2 in ( ("and" ,ar) , [miaod ar Det ] ) - , let ar = 2 in ( ("or" ,ar) , [miaod ar Det ] ) - , let ar = 1 in ( ("not" ,ar) , [miaod ar Det ] ) - ] +primOps :: DFunctAr -> Maybe [QMode (NIX DFunct)] -- XXX ,UMode +primOps = go + where + go ("-" ,1) = Just [miaod 1 Det ] + go ("^" ,2) = Just [miaod 2 Det ] + go ("|" ,2) = Just [miaod 2 Det ] + go ("-" ,2) = Just $ [miaod 2 Det ] ++ opinvd 2 Det + go ("/" ,2) = Just [miaod 2 Det ] + go ("*" ,2) = Just [miaod 2 Det ] + go ("**" ,2) = Just [miaod 2 Det ] + go ("&" ,2) = Just [miaod 2 Det ] + go ("%" ,2) = Just [miaod 2 Det ] + go ("+" ,2) = Just $ [miaod 2 Det ] ++ opinvd 2 Det + + go ("mod" ,1) = Just [miaod 1 Det ] + go ("abs" ,1) = Just [miaod 1 Det ] + go ("log" ,1) = Just [miaod 1 Det ] + go ("exp" ,1) = Just [miaod 1 Det ] + + go ("<=" ,2) = Just [miaod 2 Det ] + go ("<" ,2) = Just [miaod 2 Det ] + go ("=" ,2) = Just [miaod 2 Det ] + go (">=" ,2) = Just [miaod 2 Det ] + go (">" ,2) = Just [miaod 2 Det ] + go ("!=" ,2) = Just [miaod 2 Det ] + + go ("and" ,2) = Just [miaod 2 Det ] + go ("or" ,2) = Just [miaod 2 Det ] + + go ("true" ,0) = Just [miaod 0 Det ] + go ("false",0) = Just [miaod 0 Det ] + go ("null" ,0) = Just [miaod 0 Det ] + + go ("!" ,1) = Just [miaod 1 Det ] + go ("not" ,1) = Just [miaod 1 Det ] + + go _ = Nothing primPossible :: (DFunct,[ModedVar],ModedVar) -> Either Bool (BackendAction ()) -primPossible (f,mvis,mvo) = maybe (Left False) go $ M.lookup (f,length mvis) primOps +primPossible (f,mvis,mvo) = maybe (Left False) go $ primOps (f,length mvis) where go :: [QMode (NIX DFunct)] -> Either Bool (BackendAction ()) go [] = Left True diff --git a/src/Dyna/Backend/Python/Backend.hs b/src/Dyna/Backend/Python/Backend.hs index 75c9da6..279d6b1 100644 --- a/src/Dyna/Backend/Python/Backend.hs +++ b/src/Dyna/Backend/Python/Backend.hs @@ -60,7 +60,7 @@ isFree v = nSub (v^.mv_mi) nfree builtins :: BackendPossible PyDopeBS builtins (f,is,o) = case () of _ | all isGround is - -> maybe (Left False) gencall $ M.lookup (f,length is) constants + -> maybe (Left False) gencall $ constants (f,length is) where gencall pc = case () of _ | isFree o -> @@ -98,51 +98,54 @@ builtins (f,is,o) = case () of [(x^.mv_var, nuniv)] _ -> Left True - _ | M.member (f,length is) constants -> Left True + _ | MA.isJust (constants (f,length is)) -> Left True _ -> Left False infixOp op _ vis = sepBy op $ mpv vis mpv = map (pretty . (^.mv_var)) -constants :: M.Map (DFunct,Int) PyDopeBS -constants = M.fromList - [(("+",2) , PDBS $ infixOp "+" ) - ,(("-",2) , PDBS $ infixOp "-" ) - ,(("*",2) , PDBS $ infixOp "*" ) - ,(("/",2) , PDBS $ infixOp "/" ) - ,(("^",2) , PDBS $ infixOp "^" ) - ,(("&",2) , PDBS $ infixOp "&" ) - ,(("|",2) , PDBS $ infixOp "|" ) - ,(("%",2) , PDBS $ infixOp "%" ) - ,(("**",2) , PDBS $ infixOp "**" ) - ,(("==",2) , PDBS $ infixOp "==" ) - ,(("!=",2) , PDBS $ infixOp "!=" ) - ,(("<",2) , PDBS $ infixOp "<" ) - ,(("<=",2) , PDBS $ infixOp "<=" ) - ,((">",2) , PDBS $ infixOp ">" ) - ,((">=",2) , PDBS $ infixOp ">=" ) - ,(("=",2) , PDBS $ infixOp "=" ) - ,(("!=",2) , PDBS $ infixOp "!=" ) - ,(("and",2) , PDBS $ infixOp "and" ) - ,(("or",2) , PDBS $ infixOp "or" ) - - ,(("true",0) , PDBS $ nullary "True" ) - ,(("false",0) , PDBS $ nullary "False") - ,(("null",0) , PDBS $ nullary "None" ) - - ,(("-",1) , PDBS $ call "-" ) - ,(("!",1) , PDBS $ call "not" ) - ,(("not",1) , PDBS $ call "not" ) - ,(("mod",1) , PDBS $ call "mod" ) - ,(("abs",1) , PDBS $ call "abs" ) - ,(("log",1) , PDBS $ call "log" ) - ,(("exp",1) , PDBS $ call "exp" ) - ,(("eval",1) , PDBS $ call "None;exec ") - -- XXX not quite what we want, but something like this might - -- be nice to have. - -- ,(("pair",2) , PDBS $ call "" ) - ] +constants :: DFunctAr -> Maybe PyDopeBS +constants = go where + go ("-",1) = Just $ PDBS $ call "-" + go ("^",2) = Just $ PDBS $ infixOp "^" + go ("|",2) = Just $ PDBS $ infixOp "|" + go ("-",2) = Just $ PDBS $ infixOp "-" + go ("/",2) = Just $ PDBS $ infixOp "/" + go ("*",2) = Just $ PDBS $ infixOp "*" + go ("**",2) = Just $ PDBS $ infixOp "**" + go ("&",2) = Just $ PDBS $ infixOp "&" + go ("%",2) = Just $ PDBS $ infixOp "%" + go ("+",2) = Just $ PDBS $ infixOp "+" + + go ("mod",1) = Just $ PDBS $ call "mod" + go ("abs",1) = Just $ PDBS $ call "abs" + go ("log",1) = Just $ PDBS $ call "log" + go ("exp",1) = Just $ PDBS $ call "exp" + + go ("<=",2) = Just $ PDBS $ infixOp "<=" + go ("<",2) = Just $ PDBS $ infixOp "<" + go ("=",2) = Just $ PDBS $ infixOp "=" + -- XXX "==" means something else in Dyna + go ("==",2) = Just $ PDBS $ infixOp "==" + go (">=",2) = Just $ PDBS $ infixOp ">=" + go (">",2) = Just $ PDBS $ infixOp ">" + go ("!=",2) = Just $ PDBS $ infixOp "!=" + + go ("and",2) = Just $ PDBS $ infixOp "and" + go ("or",2) = Just $ PDBS $ infixOp "or" + + go ("true",0) = Just $ PDBS $ nullary "True" + go ("false",0) = Just $ PDBS $ nullary "False" + go ("null",0) = Just $ PDBS $ nullary "None" + + go ("!",1) = Just $ PDBS $ call "not" + go ("not",1) = Just $ PDBS $ call "not" + + go ("eval",1) = Just $ PDBS $ call "None;exec " + go ("tuple",_) = Just $ PDBS $ call "" + go _ = Nothing + nullary v _ _ = v call fn _ vis = fn <> (parens $ sepBy "," $ mpv vis) @@ -306,7 +309,7 @@ driver am um {-qm-} is fh = do pythonBackend :: Backend pythonBackend = Backend builtins - (M.keysSet constants) + (MA.isJust . constants) (\o is _ _ (PDBS e) -> e o is) driver diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs index 9ba85a5..d1dad60 100644 --- a/src/Dyna/Main/Driver.hs +++ b/src/Dyna/Main/Driver.hs @@ -274,8 +274,7 @@ processFile fileName = bracket openOut hClose go uPlans = combineUpdatePlans - $ map (\x -> (x, planEachEval be_b - (flip S.member be_c) x)) + $ map (\x -> (x, planEachEval be_b be_c x)) frs {- -- 2.50.1