qute

  1-- SPDX-FileCopyrightText: 2026 Sören Tempel <soeren+git@soeren-tempel.net>
  2--
  3-- SPDX-License-Identifier: GPL-3.0-only
  4
  5-- | This module implements type classes on top of 'Language.QBE.Types' that
  6-- implement a map operation over the 'Language.QBE.Value',
  7-- 'Language.QBE.UserIdent', and 'Language.QBE.GlobalIdent' used by AST nodes.
  8module Language.QBE.Uses
  9  ( Value (..),
 10    GlobalIdent (..),
 11    UserIdent (..),
 12  )
 13where
 14
 15import Data.Map qualified as Map
 16import Language.QBE.Types qualified as Q
 17
 18mapFieldType :: Q.Field -> (Q.UserIdent -> Q.UserIdent) -> Q.Field
 19mapFieldType (sty, n) f = (mapType sty f, n)
 20
 21-- | Type class for AST nodes using a 'Q.UserIdent' internally.
 22class UserIdent a where
 23  -- | Invoke the provided function for each 'Q.UserIdent' within the AST node @a@.
 24  mapType :: a -> (Q.UserIdent -> Q.UserIdent) -> a
 25
 26instance UserIdent Q.TypeDef where
 27  mapType ty@(Q.TypeDef {Q.aggName = name, Q.aggType = aTy}) f =
 28    ty {Q.aggName = f name, Q.aggType = mapType aTy f}
 29
 30instance UserIdent Q.SubType where
 31  mapType (Q.SUserDef uid) f = Q.SUserDef $ f uid
 32  mapType ty@(Q.SExtType _) _ = ty
 33
 34instance UserIdent Q.AggType where
 35  mapType (Q.ARegular fields) f = Q.ARegular $ map (`mapFieldType` f) fields
 36  mapType (Q.AUnion fields) f = Q.AUnion $ map (map (`mapFieldType` f)) fields
 37  mapType (Q.AOpaque w64) _ = Q.AOpaque w64
 38
 39instance UserIdent Q.Abity where
 40  mapType (Q.AUserDef uid) f = Q.AUserDef (f uid)
 41  mapType abity _ = abity
 42
 43instance UserIdent Q.FuncDef where
 44  mapType func@(Q.FuncDef {Q.fAbity = Just abity}) f =
 45    func {Q.fAbity = Just $ mapType abity f}
 46  mapType func _ = func
 47
 48------------------------------------------------------------------------
 49
 50replaceGlobal :: (Q.GlobalIdent -> Q.GlobalIdent) -> Q.Value -> Q.Value
 51replaceGlobal _ v@(Q.VLocal _) = v
 52replaceGlobal f (Q.VConst dynConst) =
 53  Q.VConst $ mapGlobals dynConst f
 54
 55-- | Type class for AST nodes using a 'Q.GlobalIdent' internally.
 56class GlobalIdent a where
 57  -- | Invoke the provided function for each 'Q.GlobalIdent' within the AST node @a@.
 58  mapGlobals :: a -> (Q.GlobalIdent -> Q.GlobalIdent) -> a
 59
 60instance GlobalIdent Q.Const where
 61  mapGlobals (Q.Global i) f = Q.Global (f i)
 62  mapGlobals c@(Q.DFP _) _ = c
 63  mapGlobals c@(Q.SFP _) _ = c
 64  mapGlobals c@(Q.Number _) _ = c
 65
 66instance GlobalIdent Q.DynConst where
 67  mapGlobals (Q.Const c) f = Q.Const $ mapGlobals c f
 68  mapGlobals (Q.Thread i) f = Q.Thread (f i)
 69  mapGlobals (Q.Common i) f = Q.Common (f i)
 70  mapGlobals (Q.Extern i) f = Q.Extern (f i)
 71  mapGlobals (Q.ExternThread i) f = Q.ExternThread (f i)
 72
 73instance GlobalIdent Q.DataDef where
 74  mapGlobals def f =
 75    def
 76      { Q.name = f $ Q.name def,
 77        Q.objs = map (`mapGlobals` f) $ Q.objs def
 78      }
 79
 80instance GlobalIdent Q.DataObj where
 81  mapGlobals o@(Q.OZeroFill _) _ = o
 82  mapGlobals (Q.OItem ty items) f =
 83    Q.OItem ty $ map (`mapGlobals` f) items
 84
 85instance GlobalIdent Q.DataItem where
 86  mapGlobals (Q.DSymOff ident off) f = Q.DSymOff (f ident) off
 87  mapGlobals (Q.DConst c) f = Q.DConst $ mapGlobals c f
 88  mapGlobals s@(Q.DString _) _ = s
 89
 90instance GlobalIdent Q.FuncDef where
 91  mapGlobals func f =
 92    func
 93      { Q.fName = f (Q.fName func),
 94        Q.fBlock = Map.map (`mapOperands` replaceGlobal f) $ Q.fBlock func
 95      }
 96
 97------------------------------------------------------------------------
 98
 99-- | Type class for AST nodes using a 'Q.Value' internally.
100class Value a where
101  -- | Invoke the provided function for each 'Q.Value' within the AST node @a@.
102  mapOperands :: a -> (Q.Value -> Q.Value) -> a
103
104instance Value Q.FuncArg where
105  mapOperands fa f =
106    case fa of
107      Q.ArgReg a v -> Q.ArgReg a (f v)
108      Q.ArgEnv v -> Q.ArgEnv (f v)
109      Q.ArgVar -> Q.ArgVar
110
111instance Value Q.JumpInstr where
112  mapOperands ji f =
113    case ji of
114      Q.Jump ident -> Q.Jump ident
115      Q.Jnz v ifT ifF -> Q.Jnz (f v) ifT ifF
116      Q.Return mayVal -> Q.Return (f <$> mayVal)
117      Q.Halt -> Q.Halt
118
119instance Value Q.Instr where
120  mapOperands instr f =
121    case instr of
122      Q.Add lhs rhs -> Q.Add (f lhs) (f rhs)
123      Q.Sub lhs rhs -> Q.Sub (f lhs) (f rhs)
124      Q.Div lhs rhs -> Q.Div (f lhs) (f rhs)
125      Q.Mul lhs rhs -> Q.Mul (f lhs) (f rhs)
126      Q.Neg val -> Q.Neg (f val)
127      Q.URem lhs rhs -> Q.URem (f lhs) (f rhs)
128      Q.Rem lhs rhs -> Q.Rem (f lhs) (f rhs)
129      Q.UDiv lhs rhs -> Q.UDiv (f lhs) (f rhs)
130      Q.Or lhs rhs -> Q.Or (f lhs) (f rhs)
131      Q.Xor lhs rhs -> Q.Xor (f lhs) (f rhs)
132      Q.And lhs rhs -> Q.And (f lhs) (f rhs)
133      Q.Sar lhs rhs -> Q.Sar (f lhs) (f rhs)
134      Q.Shr lhs rhs -> Q.Shr (f lhs) (f rhs)
135      Q.Shl lhs rhs -> Q.Shl (f lhs) (f rhs)
136      Q.Alloc siz val -> Q.Alloc siz (f val)
137      Q.Load ty val -> Q.Load ty (f val)
138      Q.CompareInt a c lhs rhs -> Q.CompareInt a c (f lhs) (f rhs)
139      Q.CompareFloat a c lhs rhs -> Q.CompareFloat a c (f lhs) (f rhs)
140      Q.Ext n val -> Q.Ext n (f val)
141      Q.FloatToInt a b val -> Q.FloatToInt a b (f val)
142      Q.IntToFloat a b val -> Q.IntToFloat a b (f val)
143      Q.TruncDouble val -> Q.TruncDouble (f val)
144      Q.Cast val -> Q.Cast (f val)
145      Q.Copy val -> Q.Copy (f val)
146      Q.VAArg val -> Q.VAArg (f val)
147
148instance Value Q.VolatileInstr where
149  mapOperands vi f =
150    case vi of
151      Q.Store ty lhs rhs -> Q.Store ty (f lhs) (f rhs)
152      Q.VAStart val -> Q.VAStart (f val)
153      Q.Blit lhs rhs w -> Q.Blit (f lhs) (f rhs) w
154      dbg@(Q.DBGLoc {}) -> dbg
155
156instance Value Q.Statement where
157  mapOperands s f =
158    case s of
159      Q.Assign ident ty instr -> Q.Assign ident ty (mapOperands instr f)
160      Q.Call retTy func args -> Q.Call retTy (f func) (map (`mapOperands` f) args)
161      Q.Volatile vi -> Q.Volatile (mapOperands vi f)
162
163instance Value Q.Phi where
164  mapOperands p f = p {Q.pLabels = Map.map f (Q.pLabels p)}
165
166instance Value Q.Block where
167  mapOperands b f =
168    b
169      { Q.phi = map (`mapOperands` f) $ Q.phi b,
170        Q.stmt = map (`mapOperands` f) $ Q.stmt b,
171        Q.term = mapOperands (Q.term b) f
172      }