wip: adding native flag to raw binops, but not using it yet

Author: aslanix

compiler/src/IR2Raw.hs

@@ -246,17 +246,19 @@ _raisePC :: RawVar -> TM ()
 _raisePC raiseBy = do
   pc <- getPC
   pc' <- freshRawVarWith "_pc_"
-  tell [ AssignRaw pc' (Bin Basics.LatticeJoin pc raiseBy)
+  tell [ AssignRaw pc' (_default_bin Basics.LatticeJoin pc raiseBy)
        , SetState MonPC pc'
        ]
 
+_default_bin op r1 r2 = Bin op (UseNativeBinop False) r1 r2 
+
 -- | Generate instructions raising the blocking label with the label in the given variable.
 -- Not to be used directly, see functions below instead.
 _raiseBlock :: RawVar -> TM ()
 _raiseBlock raiseBy = do
   bl  <- getBlock
   bl' <- freshRawVarWith "_bl_"
-  tell [ AssignRaw bl' (Bin Basics.LatticeJoin bl raiseBy)
+  tell [ AssignRaw bl' (_default_bin Basics.LatticeJoin bl raiseBy)
        , SetState MonBlock bl'
        ]
 
@@ -351,7 +353,7 @@ compLabel = \case
     then return r
     else foldM (\(r1 :: RawVar) (r2 :: RawVar) -> do
                    r' :: RawVar <- freshRawVarWith "_lbl_"
-                   tell [ AssignRaw r' $ Bin Basics.LatticeJoin r1 r2 ]
+                   tell [ AssignRaw r' $ _default_bin Basics.LatticeJoin r1 r2 ]
                    return r'
                ) r rs
   PC -> getPC
@@ -500,7 +502,7 @@ expr2rawComp = \case
     -- (for operations where the result type is fixed).
     let basicBinOpComp =
          return SimpleRawComp
-          { cVal = RBin v1 v2 $ Bin op
+          { cVal = RBin v1 v2 $ Bin op (UseNativeBinop True)
           , cValLbl = Join PC (ValLbl v1) [ValLbl v2]
           , cTyLbl = PC
           }
@@ -558,12 +560,12 @@ expr2rawComp = \case
       -- Note: Even though the result depends on the types of the parameters, it is sufficient to join their
       -- value labels into the result's value label, due to the invariant tyLbl ⊑ valLbl.
       Basics.Eq -> return ComplexRawComp
-        { ccVal = RBin v1 v2 $ Bin op
+        { ccVal = RBin v1 v2 $ Bin op (UseNativeBinop False)
         , ccValLbl = \resValLbl -> Join PC (ValLbl v1) [ValLbl v2, resValLbl]
         , ccTyLbl = const PC -- The result type is always boolean
         }
       Basics.Neq -> return ComplexRawComp
-        { ccVal = RBin v1 v2 $ Bin op
+        { ccVal = RBin v1 v2 $ Bin op (UseNativeBinop False)
         , ccValLbl = \resValLbl -> Join PC (ValLbl v1) [ValLbl v2, resValLbl]
         , ccTyLbl = const PC -- The result type is always boolean
         }

compiler/src/Raw.hs

@@ -99,7 +99,7 @@ data RTAssertion
 -- What would be possible is to introduce a pre-processing which translates IR expressions into
 -- categorized expressions, which could then slightly simplify handling at IR2Raw.
 data RawExpr
-  = Bin Basics.BinOp RawVar RawVar
+  = Bin Basics.BinOp UseNativeBinop RawVar RawVar
   | Un Basics.UnaryOp RawVar
   | ProjectLVal VarAccess LValField
   | ProjectState MonComponent
@@ -119,6 +119,12 @@ data RawExpr
   | ConstructLVal RawVar RawVar RawVar
   deriving (Eq, Show)
 
+-- | For equality and inequality, we generally defer to the runtime. However 
+-- when we know that the operation involves simple types we can generate 
+-- faster code, avoiding calling the runtime functions
+-- 
+newtype UseNativeBinop = UseNativeBinop Bool
+  deriving (Eq, Show)
 
 data RawInst
   -- | Assign the result of the given simple expression (an unlabelled value) to the given raw variable.
@@ -229,7 +235,7 @@ data InstructionType
 
 instructionType :: RawInst -> InstructionType
 instructionType i = case i of 
-  AssignRaw _ (Bin Basics.LatticeJoin _ _) -> LabelSpecificInstruction
+  AssignRaw _ (Bin Basics.LatticeJoin _ _ _) -> LabelSpecificInstruction
   AssignRaw _ (ProjectState MonPC) -> LabelSpecificInstruction
   AssignRaw _ (ProjectState MonBlock) -> LabelSpecificInstruction
   AssignRaw _ (ProjectState R0_Lev)  -> LabelSpecificInstruction
@@ -268,7 +274,7 @@ ppFunDef ( FunDef hfn consts insts  _ )
 
 
 ppRawExpr :: RawExpr -> PP.Doc
-ppRawExpr (Bin binop va1 va2) =
+ppRawExpr (Bin binop _ va1 va2) = -- TODO: 2025-07-31; also print the fast flag 
   ppId va1 <+> text (show binop) <+> ppId va2
 ppRawExpr (Un op v) =
   text (show op) <> PP.parens (ppId v)

compiler/src/RawDefUse.hs

@@ -192,7 +192,7 @@ instance Trav a => Trav [a]
 instance Usable RawExpr b where 
   use e =     
       case e of 
-        Raw.Bin _ x y -> use [x,y] 
+        Raw.Bin _ _ x y -> use [x,y] 
         Raw.Un _ x -> use x
         Raw.ProjectLVal x _ -> use x
         Raw.ProjectState _ -> return ()

compiler/src/RawOpt.hs

@@ -44,7 +44,7 @@ instance Substitutable RawVar where
 instance Substitutable RawExpr where 
   apply subst e = 
     case e of 
-      Bin op x y -> Bin op (apply subst x) (apply subst y)
+      Bin op use_native x y -> Bin op use_native  (apply subst x) (apply subst y)
       Un op x -> Un op (apply subst x)
       ListCons x y -> ListCons x (apply subst y)
       WithRecord x fs -> WithRecord (apply subst x) fs 
@@ -95,7 +95,8 @@ data PState =
              stateJoins :: Map (RawVar, RawVar) RawVar,           -- computed joins
              stateSubst :: Subst,
              stateChange:: ChangeFlag,
-             stateTypes :: Map RawVar RawType                     -- for assertions optimizations
+             stateRawVarTypes :: Map RawVar RawType,              -- for assertions optimizations
+             stateLValTypes :: Map VarName RawType                -- for assertions optimizations
            }
 
 -- 2021-02-28; AA 
@@ -136,7 +137,7 @@ instance MarkUsed a => MarkUsed [a] where
 
 instance MarkUsed RawExpr where 
   markUsed e = case e of 
-    Bin _ x y -> markUsed [x,y]
+    Bin _ _ x y -> markUsed [x,y]
     Un _ x -> markUsed x
     ProjectLVal x _ -> markUsed x
     ProjectState _ -> return ()
@@ -191,7 +192,7 @@ guessType :: RawExpr -> Maybe RawType
 guessType = \case
   Const lit -> typeOfLit lit
 
-  Bin op _ _ -> case op of
+  Bin op _ _ _ -> case op of
     Basics.Plus -> Just RawNumber
     Basics.Minus -> Just RawNumber
     Basics.Div -> Just RawNumber
@@ -256,8 +257,11 @@ guessType = \case
   Base _ -> Nothing
   ConstructLVal _ _ _ -> Nothing
 
-_setType x t = modify (\pstate -> 
-          pstate { stateTypes = Map.insert x t (stateTypes pstate)})
+_setRawType x t = modify (\pstate -> 
+          pstate { stateRawVarTypes = Map.insert x t (stateRawVarTypes pstate)})
+
+_setLValType x t = modify (\pstate -> 
+          pstate { stateLValTypes = Map.insert x t (stateLValTypes pstate)})
 
 -- Partially evaluate instruction. This is called multiple times in the optimization sequence.
 -- First pass: partially evaluate functions (instructions).
@@ -275,7 +279,7 @@ pevalInst i = do
         case monLookup p pstate of -- lookup the known state of the monitor component
           Just r' -> _omit $ addSubst r r' -- The state can already be found in r', therefore the assignment to r can be omitted, and we have to remember to substitute r with r'.
           Nothing -> _keep $ monInsert p r -- remember that PC/block can be found in variable r
-      AssignRaw r (Bin Basics.LatticeJoin x y) -> do 
+      AssignRaw r (Bin Basics.LatticeJoin (UseNativeBinop False) x y) -> do 
         if x == y then _omit (addSubst r x) -- trivial join
         else do
           case Map.lookup (x,y) (stateJoins pstate) of 
@@ -303,21 +307,34 @@ pevalInst i = do
             let m0 = stateLVals pstate 
             let m1 = Map.insert (v, field) r m0 
             put $ pstate { stateLVals = m1 }
+
+            -- 2025-07-31; now also examine the type information 
+            -- which is useful for booleans 
+            case (Map.lookup v (stateLValTypes pstate)) of 
+              Nothing -> return ()
+              Just t  -> _setRawType r t
+
       AssignRaw r rexpr -> _keep $ do
         markUsed rexpr 
         case guessType rexpr of 
             Nothing -> return ()
-            Just ty -> _setType r ty 
+            Just ty -> _setRawType r ty 
 
 
-      AssignLVal v complexExpr -> _keep $ markUsed complexExpr
+      AssignLVal v complexExpr -> _keep $ do
+        case complexExpr of 
+            Bin op (UseNativeBinop False) r1 r2 | op `elem` [Basics.Eq, Basics.Neq]  -> 
+              _setLValType v RawBoolean
+            _ -> return ()
+        _keep $ markUsed complexExpr
+
       SetState p r -> _keep $ do 
         markUsed r
         monInsert p r        
       RTAssertion (AssertType r rt) -> do 
-        case Map.lookup r (stateTypes pstate) of 
+        case Map.lookup r (stateRawVarTypes pstate) of 
           Just rt' | rt' == rt -> return Nothing
-          _ -> _keep $ _setType r rt >> markUsed r        
+          _ -> _keep $ _setRawType r rt >> markUsed r        
       -- RTAssertion (AssertEqTypes opt_ls x y) -> do
       --   let _m = stateTypes pstate
       --   let keep = _keep $ markUsed [x,y]
@@ -331,7 +348,7 @@ pevalInst i = do
       --           else keep
       --     _ -> keep
       RTAssertion (AssertTypesBothStringsOrBothNumbers x y) -> do 
-        let _m = stateTypes pstate 
+        let _m = stateRawVarTypes pstate 
         let keep = _keep $ markUsed [x,y]
         case (Map.lookup x _m, Map.lookup y _m) of 
           (Just t1 , Just t2) | t1 == t2 -> 
@@ -518,7 +535,8 @@ funopt (FunDef hfn consts bb ir) =
                        stateJoins = Map.empty,
                        stateSubst = Subst (m_subst),
                        stateChange = False,
-                       stateTypes = constTypes
+                       stateRawVarTypes = constTypes,
+                       stateLValTypes = Map.empty
                        }
       (bb', _, _) = runRWS (peval bb) () pstate
       new = FunDef hfn consts' bb' ir  

compiler/src/Stack2JS.hs

@@ -583,7 +583,7 @@ instance ToJS RawExpr where
            Raw.FieldValLev -> monStateToJs MonPC
            Raw.FieldTypLev -> monStateToJs MonPC)
       e@(ProjectLVal _ _) -> return $ ppRawExpr e
-      Bin binop va1 va2 -> return $
+      Bin binop _ va1 va2 -> return $
         let text' = (text . binOpToJS) binop in
           if isInfixBinop binop
           then hsep [ ppId va1, text', ppId va2 ]

tests/_unautomated/loop.trp

@@ -1,6 +1,6 @@
 let
   fun loop n =
-    if n <= 10 then
+    if n = 10 then
       let val _ = printWithLabels n
       in loop (n + 1)
       end